summaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2005-01-03 15:34:18 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2005-01-03 15:34:18 +0000
commit723a0aca88a81e72f4a01b3e2fcd840b63ccc8f6 (patch)
tree163dcbd1c122008f040766e9e59e37cdd5307c1c /gcc/ada
parentbe489ae0b3d8da2a509806a3438683f3906a5492 (diff)
downloadgcc-723a0aca88a81e72f4a01b3e2fcd840b63ccc8f6.tar.gz
* bld.ads, bld.adb, bld-io.ads, bld-io.adb, gprcmd.adb,
gpr2make.ads, gpr2make.adb: Remove gpr2make, replaced by gprmake. * Makefile.in: Add support to build shared Ada libraries on solaris x86 Remove gpr2make, replaced by gprmake. Remove references to gnatmem and libaddr2line. Add indepsw.adb<indepsw-linux.adb to TOOLS_TARGET_PAIRS for IA64 linux. (gnatlib-shared-darwin): Add "-fno-common" to GNATLIBCFLAGS. Add support for specialized version of Ada.Numerics.Aux for Darwin: use a-numaux-darwin.ads and a-numaux-darwin.adb Enable mlib-tgt-lynxos.adb on lynxos. * Make-lang.in: Remove rules for gpr2make. When generating sdefault.adb, do not call Relocate_Path on S3 for function Target_Name, as it is not a path. Remove references to gnatmem and libaddr2line. * a-numaux-darwin.ads, a-numaux-darwin.adb, g-soccon-darwin.ads: New files. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@92831 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/Make-lang.in48
-rw-r--r--gcc/ada/Makefile.in65
-rw-r--r--gcc/ada/a-numaux-darwin.adb186
-rw-r--r--gcc/ada/a-numaux-darwin.ads109
-rw-r--r--gcc/ada/bld-io.adb285
-rw-r--r--gcc/ada/bld-io.ads73
-rw-r--r--gcc/ada/bld.adb3622
-rw-r--r--gcc/ada/bld.ads38
-rw-r--r--gcc/ada/g-soccon-darwin.ads163
-rw-r--r--gcc/ada/gpr2make.adb34
-rw-r--r--gcc/ada/gpr2make.ads30
-rw-r--r--gcc/ada/gprcmd.adb612
12 files changed, 481 insertions, 4784 deletions
diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in
index 02510b3b157..9a03fafa6d7 100644
--- a/gcc/ada/Make-lang.in
+++ b/gcc/ada/Make-lang.in
@@ -321,10 +321,6 @@ ada.all.cross:
then \
$(MV) gnatmake$(exeext) gnatmake-cross$(exeext); \
fi
- -if [ -f gnatmem$(exeext) ] ; \
- then \
- $(MV) gnatmem$(exeext) gnatmem-cross$(exeext); \
- fi
-if [ -f gnatname$(exeext) ] ; \
then \
$(MV) gnatname$(exeext) gnatname-cross$(exeext); \
@@ -353,14 +349,6 @@ ada.all.cross:
then \
$(MV) gprmake$(exeext) gprmake-cross$(exeext); \
fi
- -if [ -f gpr2make$(exeext) ] ; \
- then \
- $(MV) gpr2make$(exeext) gpr2make-cross$(exeext); \
- fi
- -if [ -f gprcmd$(exeext) ] ; \
- then \
- $(MV) gprcmd$(exeext) gprcmd-cross$(exeext); \
- fi
ada.start.encap:
ada.rest.encap:
@@ -447,7 +435,7 @@ ada.install-normal:
# 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, gpr2make, gprcmd
+# gnatsym, gprmake
ada.install-common:
$(MKDIR) $(DESTDIR)$(bindir)
-if [ -f gnat1$(exeext) ] ; \
@@ -572,17 +560,6 @@ ada.install-common:
fi
-if [ -f gnat1$(exeext) ] ; \
then \
- if [ -f gnatmem-cross$(exeext) ] ; \
- then \
- $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmem$(exeext); \
- $(INSTALL_PROGRAM) gnatmem-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatmem$(exeext); \
- else \
- $(RM) $(DESTDIR)$(bindir)/gnatmem$(exeext); \
- $(INSTALL_PROGRAM) gnatmem$(exeext) $(DESTDIR)$(bindir)/gnatmem$(exeext); \
- fi ; \
- fi
- -if [ -f gnat1$(exeext) ] ; \
- then \
if [ -f gnatname-cross$(exeext) ] ; \
then \
$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext); \
@@ -651,22 +628,6 @@ ada.install-common:
$(INSTALL_PROGRAM) gprmake$(exeext) $(DESTDIR)$(bindir)/gprmake$(exeext); \
fi ; \
fi
- -if [ -f gnat1$(exeext) ] ; \
- then \
- if [ -f gpr2make$(exeext) ] ; \
- then \
- $(RM) $(DESTDIR)$(bindir)/gpr2make$(exeext); \
- $(INSTALL_PROGRAM) gpr2make$(exeext) $(DESTDIR)$(bindir)/gpr2make$(exeext); \
- fi ; \
- fi
- -if [ -f gnat1$(exeext) ] ; \
- then \
- if [ -f gprcmd$(exeext) ] ; \
- then \
- $(RM) $(DESTDIR)$(bindir)/gprcmd$(exeext); \
- $(INSTALL_PROGRAM) gprcmd$(exeext) $(DESTDIR)$(bindir)/gprcmd$(exeext); \
- fi ; \
- fi
#
# Gnatsym is only built on some platforms, including VMS
#
@@ -738,7 +699,6 @@ ada.uninstall:
-$(RM) $(DESTDIR)$(bindir)/gnatlink$(exeext)
-$(RM) $(DESTDIR)$(bindir)/gnatls$(exeext)
-$(RM) $(DESTDIR)$(bindir)/gnatmake$(exeext)
- -$(RM) $(DESTDIR)$(bindir)/gnatmem$(exeext)
-$(RM) $(DESTDIR)$(bindir)/gnatname$(exeext)
-$(RM) $(DESTDIR)$(bindir)/gnatprep$(exeext)
-$(RM) $(DESTDIR)$(bindir)/gnatxref$(exeext)
@@ -755,7 +715,6 @@ ada.uninstall:
-$(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)-gnatmem$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatname$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext)
@@ -772,7 +731,6 @@ ada.uninstall:
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatlink$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatls$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatmake$(exeext)
- -$(RM) $(DESTDIR)$(tooldir)/bin/gnatmem$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatname$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatxref$(exeext)
@@ -801,14 +759,12 @@ ada.distclean:
-$(RM) gnatlink$(exeext)
-$(RM) gnatls$(exeext)
-$(RM) gnatmake$(exeext)
- -$(RM) gnatmem$(exeext)
-$(RM) gnatname$(exeext)
-$(RM) gnatprep$(exeext)
-$(RM) gnatfind$(exeext)
-$(RM) gnatxref$(exeext)
-$(RM) gnatclean$(exeext)
-$(RM) gnatsym$(exeext)
- -$(RM) gpr2make$(exeext)
-$(RM) gprmake$(exeext)
# Gnatlbr is only used on VMS
-$(RM) gnatlbr$(exeext)
@@ -969,7 +925,7 @@ ada/stamp-sdefault : $(srcdir)/version.c Makefile
$(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 Relocate_Path (S0, S3);" >>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
diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in
index 45490c890da..43809186177 100644
--- a/gcc/ada/Makefile.in
+++ b/gcc/ada/Makefile.in
@@ -133,8 +133,6 @@ THREAD_KIND = native
THREADSLIB =
GMEM_LIB =
MISCLIB =
-SYMLIB =
-ADDR2LINE_SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
SYMDEPS = $(LIBINTL_DEP)
OUTPUT_OPTION = @OUTPUT_OPTION@
@@ -716,7 +714,6 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
THREADSLIB = -lposix4 -lthread
MISCLIB = -lposix4 -lnsl -lsocket
- SYMLIB = $(ADDR2LINE_SYMLIB)
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -800,10 +797,13 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),)
g-soliop.ads<g-soliop-solaris.ads \
system.ads<system-solaris-x86.ads
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-solaris.adb
+
THREADSLIB = -lposix4 -lthread
MISCLIB = -lposix4 -lnsl -lsocket
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
+ GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(LIB_VERSION)
endif
@@ -829,7 +829,6 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
mlib-tgt.adb<mlib-tgt-linux.adb \
indepsw.adb<indepsw-linux.adb
- SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -877,7 +876,6 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
mlib-tgt.adb<mlib-tgt-linux.adb
GNATLIB_SHARED = gnatlib-shared-dual
- SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB= -lc_r
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
@@ -1012,7 +1010,6 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
TOOLS_TARGET_PAIRS = mlib-tgt.adb<mlib-tgt-hpux.adb
TGT_LIB = /usr/lib/libcl.a
THREADSLIB = -lpthread
- SYMLIB = $(ADDR2LINE_SYMLIB)
GMEM_LIB = gmemlib
soext = .sl
SO_OPTS = -Wl,+h,
@@ -1081,11 +1078,11 @@ ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),)
indepsw.adb<indepsw-aix.adb
GMEM_LIB = gmemlib
- SYMLIB = $(ADDR2LINE_SYMLIB)
-
endif
ifeq ($(strip $(filter-out lynxos,$(osys))),)
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-lynxos.adb
+
ifeq ($(strip $(filter-out %86 lynxos,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-numaux.adb<a-numaux-x86.adb \
@@ -1130,7 +1127,6 @@ ifeq ($(strip $(filter-out lynxos,$(osys))),)
s-tpopsp.adb<s-tpopsp-lynxos.adb \
system.ads<system-lynxos-ppc.ads
endif
-
endif
endif
@@ -1168,7 +1164,6 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-tru64.adb
GMEM_LIB=gmemlib
- SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB = -lpthread -lmach -lexc -lrt
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-default
@@ -1304,7 +1299,6 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
indepsw.adb<indepsw-mingw.adb
MISCLIB = -lwsock32
- SYMLIB = $(ADDR2LINE_SYMLIB)
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
EXTRA_GNATTOOLS = ../../gnatdll$(exeext)
@@ -1335,7 +1329,6 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(arch) $(osys))),)
mlib-tgt.adb<mlib-tgt-linux.adb \
indepsw.adb<indepsw-linux.adb
- SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -1358,7 +1351,10 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
s-taspri.ads<s-taspri-linux.ads \
system.ads<system-linux-ia64.ads
- TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-linux.adb
+ TOOLS_TARGET_PAIRS = \
+ mlib-tgt.adb<mlib-tgt-linux.adb \
+ indepsw.adb<indepsw-linux.adb
+
MISCLIB=
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
@@ -1382,7 +1378,6 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
system.ads<system-linux-x86_64.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-linux.adb
- SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -1401,7 +1396,9 @@ ifeq ($(strip $(filter-out powerpc darwin%,$(arch) $(osys))),)
s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- g-soccon.ads<g-soccon-aix.ads \
+ g-soccon.ads<g-soccon-darwin.ads \
+ a-numaux.ads<a-numaux-darwin.ads \
+ a-numaux.adb<a-numaux-darwin.adb \
system.ads<system-darwin-ppc.ads
TOOLS_TARGET_PAIRS = \
@@ -1413,9 +1410,7 @@ ifeq ($(strip $(filter-out powerpc darwin%,$(arch) $(osys))),)
GMEM_LIB = gmemlib
LIBRARY_VERSION := $(LIB_VERSION)
-
soext = .dylib
-
endif
# The runtime library for gnat comprises two directories. One contains the
@@ -1430,7 +1425,7 @@ endif
LIBGNAT_SRCS = ada.h adaint.c adaint.h argv.c cio.c cstreams.c \
errno.c exit.c cal.c ctrl_c.c \
raise.h raise.c sysdep.c aux-io.c init.c \
- final.c tracebak.c tb-alvms.c tb-alvxw.c expect.c mkdir.c socket.c \
+ final.c tracebak.c tb-alvms.c tb-alvxw.c expect.c mkdir.c socket.c gsocket.h \
$(EXTRA_LIBGNAT_SRCS)
LIBGNAT_OBJS = adaint.o argv.o cio.o cstreams.o ctrl_c.o errno.o exit.o \
@@ -1537,14 +1532,14 @@ gnattools2: ../stamp-tools
../../gnatls$(exeext) ../../gnatprep$(exeext) \
../../gnatxref$(exeext) \
../../gnatfind$(exeext) ../../gnatname$(exeext) \
- ../../gnatclean$(exeext) ../../gprmake$(exeext) \
- ../../gprcmd$(exeext) ../../gpr2make$(exeext)
+ ../../gnatclean$(exeext) ../../gprmake$(exeext)
# These tools are only built for the native version.
gnattools3: ../stamp-tools
-# $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \
-# TOOLSCASE=native top_builddir=../../.. \
-# ../../gnatmem$(exeext) $(EXTRA_GNATTOOLS)
+ifneq ($(EXTRA_GNATTOOLS),)
+ $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \
+ TOOLSCASE=native top_builddir=../../.. $(EXTRA_GNATTOOLS)
+endif
# those tools are only built for the cross version
gnattools4: ../stamp-tools
@@ -1585,12 +1580,6 @@ gnattools4: ../stamp-tools
$(GNATLINK) -v gprmake -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
$(TOOLS_LIBS)
-../../gpr2make$(exeext): ../stamp-tools
- $(GNATMAKE) -c $(ADA_INCLUDES) gpr2make --GCC="$(CC) $(ALL_ADAFLAGS)"
- $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gpr2make
- $(GNATLINK) -v gpr2make -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
-
../../gnatprep$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatprep --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatprep
@@ -1621,25 +1610,12 @@ gnattools4: ../stamp-tools
$(GNATLINK) -v gnatsym -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
$(TOOLS_LIBS)
-../../gnatmem$(exeext): ../stamp-tools gmem.o $(SYMDEPS)
-ifeq ($(GMEM_LIB),gmemlib)
- $(GNATMAKE) -c $(ADA_INCLUDES) gnatmem --GCC="$(CC) $(ALL_ADAFLAGS)"
- $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmem
- $(GNATLINK) -v gnatmem -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- gmem.o $(SYMLIB) $(TOOLS_LIBS)
-endif
-
../../gnatdll$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatdll --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) $(GNATBIND_FLAGS) gnatdll
$(GNATLINK) -v gnatdll -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
$(TOOLS_LIBS)
-../../gprcmd$(exeext): ../stamp-tools
- $(GNATMAKE) -c $(ADA_INCLUDES) gprcmd --GCC="$(CC) $(ALL_ADAFLAGS)"
- $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gprcmd
- $(GNATLINK) -v gprcmd -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
-
../../vxaddr2line$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) vxaddr2line --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxaddr2line
@@ -1890,7 +1866,8 @@ gnatlib-shared-win32:
gnatlib-shared-darwin:
$(MAKE) $(FLAGS_TO_PASS) \
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
- GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) \
+ -fno-common" \
THREAD_KIND="$(THREAD_KIND)" \
gnatlib
$(RM) rts/libgnat$(soext) rts/libgnarl$(soext)
@@ -2039,7 +2016,7 @@ final.o : raise.h final.c
gmem.o : gmem.c
link.o : link.c
mkdir.o : mkdir.c
-socket.o : socket.c
+socket.o : socket.c gsocket.h
sysdep.o : sysdep.c
cio.o : cio.c
diff --git a/gcc/ada/a-numaux-darwin.adb b/gcc/ada/a-numaux-darwin.adb
new file mode 100644
index 00000000000..19d8881a9f4
--- /dev/null
+++ b/gcc/ada/a-numaux-darwin.adb
@@ -0,0 +1,186 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- B o d y --
+-- (Apple OS X Version) --
+-- --
+-- Copyright (C) 1998-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, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- File a-numaux.adb <- a-numaux-darwin.adb
+
+package body Ada.Numerics.Aux is
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ procedure Reduce (X : in out Double; Q : out Natural);
+ -- Implements reduction of X by Pi/2. Q is the quadrant of the final
+ -- 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;
+ function Cosine_Approx (X : Double) return Double;
+
+ pragma Inline (Reduce);
+ pragma Inline (Sine_Approx);
+ pragma Inline (Cosine_Approx);
+
+ function Cosine_Approx (X : Double) return Double is
+ XX : constant Double := X * X;
+ begin
+ return (((((16#8.DC57FBD05F640#E-08 * XX
+ - 16#4.9F7D00BF25D80#E-06) * XX
+ + 16#1.A019F7FDEFCC2#E-04) * XX
+ - 16#5.B05B058F18B20#E-03) * XX
+ + 16#A.AAAAAAAA73FA8#E-02) * XX
+ - 16#7.FFFFFFFFFFDE4#E-01) * XX
+ - 16#3.655E64869ECCE#E-14 + 1.0;
+ end Cosine_Approx;
+
+ function Sine_Approx (X : Double) return Double is
+ XX : constant Double := X * X;
+ begin
+ return (((((16#A.EA2D4ABE41808#E-09 * XX
+ - 16#6.B974C10F9D078#E-07) * XX
+ + 16#2.E3BC673425B0E#E-05) * XX
+ - 16#D.00D00CCA7AF00#E-04) * XX
+ + 16#2.222222221B190#E-02) * XX
+ - 16#2.AAAAAAAAAAA44#E-01) * (XX * X) + X;
+ end Sine_Approx;
+
+ ------------
+ -- Reduce --
+ ------------
+
+ procedure Reduce (X : in out Double; Q : out Natural) is
+ Half_Pi : constant := Pi / 2.0;
+ Two_Over_Pi : constant := 2.0 / Pi;
+
+ HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size);
+ M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant
+ P1 : constant Double := Double'Leading_Part (Half_Pi, HM);
+ P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM);
+ P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM);
+ P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM);
+ P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3
+ - P4, HM);
+ P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5);
+ K : Double := X * Two_Over_Pi;
+ begin
+ -- For X < 2.0**HM, all products below are computed exactly.
+ -- Due to cancellation effects all subtractions are exact as well.
+ -- As no double extended floating-point number has more than 75
+ -- zeros after the binary point, the result will be the correctly
+ -- rounded result of X - K * (Pi / 2.0).
+
+ while abs K >= 2.0**HM loop
+ K := K * M - (K * M - K);
+ X := (((((X - K * P1) - K * P2) - K * P3)
+ - K * P4) - K * P5) - K * P6;
+ K := X * Two_Over_Pi;
+ end loop;
+
+ if K /= K then
+
+ -- K is not a number, because X was not finite
+
+ raise Constraint_Error;
+ end if;
+
+ K := Double'Rounding (K);
+ Q := Integer (K) mod 4;
+ X := (((((X - K * P1) - K * P2) - K * P3)
+ - K * P4) - K * P5) - K * P6;
+ end Reduce;
+
+ ---------
+ -- Cos --
+ ---------
+
+ function Cos (X : Double) return Double is
+ Reduced_X : Double := abs X;
+ Quadrant : Natural range 0 .. 3;
+
+ begin
+ if Reduced_X > Pi / 4.0 then
+ Reduce (Reduced_X, Quadrant);
+
+ case Quadrant is
+ when 0 =>
+ return Cosine_Approx (Reduced_X);
+
+ when 1 =>
+ return Sine_Approx (-Reduced_X);
+
+ when 2 =>
+ return -Cosine_Approx (Reduced_X);
+
+ when 3 =>
+ return Sine_Approx (Reduced_X);
+ end case;
+ end if;
+
+ return Cosine_Approx (Reduced_X);
+ end Cos;
+
+ ---------
+ -- Sin --
+ ---------
+
+ function Sin (X : Double) return Double is
+ Reduced_X : Double := X;
+ Quadrant : Natural range 0 .. 3;
+
+ begin
+ if abs X > Pi / 4.0 then
+ Reduce (Reduced_X, Quadrant);
+
+ case Quadrant is
+ when 0 =>
+ return Sine_Approx (Reduced_X);
+
+ when 1 =>
+ return Cosine_Approx (Reduced_X);
+
+ when 2 =>
+ return Sine_Approx (-Reduced_X);
+
+ when 3 =>
+ return -Cosine_Approx (Reduced_X);
+ end case;
+ end if;
+
+ return Sine_Approx (Reduced_X);
+ end Sin;
+
+end Ada.Numerics.Aux;
diff --git a/gcc/ada/a-numaux-darwin.ads b/gcc/ada/a-numaux-darwin.ads
new file mode 100644
index 00000000000..6ca8c3c300a
--- /dev/null
+++ b/gcc/ada/a-numaux-darwin.ads
@@ -0,0 +1,109 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- S p e c --
+-- (Apple OS X Version) --
+-- --
+-- Copyright (C) 1992-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, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for use with normal Unix math functions, except for
+-- sine/cosine which have been implemented directly in Ada to get
+-- the required accuracy in OS X. Alternative packages are used
+-- on OpenVMS (different import names), VxWorks (no need for the
+-- -lm Linker_Options), and on the x86 (where we have two
+-- versions one using inline ASM, and one importing from the C long
+-- routines that take 80-bit arguments).
+
+package Ada.Numerics.Aux is
+pragma Pure (Aux);
+
+ pragma Linker_Options ("-lm");
+
+ type Double is digits 15;
+ -- Type Double is the type used to call the C routines
+
+ -- The following functions have been implemented in Ada, since
+ -- the OS X math library didn't meet accuracy requirements for
+ -- argument reduction. The implementation here has been tailored
+ -- to match Ada strict mode Numerics requirements while maintaining
+ -- maximum efficiency.
+ function Sin (X : Double) return Double;
+ pragma Inline (Sin);
+
+ function Cos (X : Double) return Double;
+ pragma Inline (Cos);
+
+ -- We import these functions directly from C. Note that we label them
+ -- all as pure functions, because indeed all of them are in fact pure!
+
+ function Tan (X : Double) return Double;
+ pragma Import (C, Tan, "tan");
+ pragma Pure_Function (Tan);
+
+ function Exp (X : Double) return Double;
+ pragma Import (C, Exp, "exp");
+ pragma Pure_Function (Exp);
+
+ function Sqrt (X : Double) return Double;
+ pragma Import (C, Sqrt, "sqrt");
+ pragma Pure_Function (Sqrt);
+
+ function Log (X : Double) return Double;
+ pragma Import (C, Log, "log");
+ pragma Pure_Function (Log);
+
+ function Acos (X : Double) return Double;
+ pragma Import (C, Acos, "acos");
+ pragma Pure_Function (Acos);
+
+ function Asin (X : Double) return Double;
+ pragma Import (C, Asin, "asin");
+ pragma Pure_Function (Asin);
+
+ function Atan (X : Double) return Double;
+ pragma Import (C, Atan, "atan");
+ pragma Pure_Function (Atan);
+
+ function Sinh (X : Double) return Double;
+ pragma Import (C, Sinh, "sinh");
+ pragma Pure_Function (Sinh);
+
+ function Cosh (X : Double) return Double;
+ pragma Import (C, Cosh, "cosh");
+ pragma Pure_Function (Cosh);
+
+ function Tanh (X : Double) return Double;
+ pragma Import (C, Tanh, "tanh");
+ pragma Pure_Function (Tanh);
+
+ function Pow (X, Y : Double) return Double;
+ pragma Import (C, Pow, "pow");
+ pragma Pure_Function (Pow);
+
+end Ada.Numerics.Aux;
diff --git a/gcc/ada/bld-io.adb b/gcc/ada/bld-io.adb
deleted file mode 100644
index 7bd01e6ac6d..00000000000
--- a/gcc/ada/bld-io.adb
+++ /dev/null
@@ -1,285 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- B L D - I O --
--- --
--- B o d y --
--- --
--- 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- 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.Text_IO;
-with Ada.Unchecked_Deallocation;
-
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Osint;
-
-package body Bld.IO is
-
- use Ada;
-
- Initial_Number_Of_Lines : constant := 100;
- Initial_Length_Of_Line : constant := 50;
-
- type Line is record
- Length : Natural := 0;
- Value : String_Access;
- Suppressed : Boolean := False;
- end record;
- -- One line of a Makefile.
- -- Length is the position of the last column in the line.
- -- Suppressed is set to True by procedure Suppress.
-
- type Line_Array is array (Positive range <>) of Line;
-
- type Buffer is access Line_Array;
-
- procedure Free is new Ada.Unchecked_Deallocation (Line_Array, Buffer);
-
- Lines : Buffer := new Line_Array (1 .. Initial_Number_Of_Lines);
- -- The lines of a Makefile
-
- Current : Positive := 1;
- -- Position of the last line in the Makefile
-
- File : Text_IO.File_Type;
- -- The current Makefile
-
- type File_Name_Data;
- type File_Name_Ref is access File_Name_Data;
-
- type File_Name_Data is record
- Value : String_Access;
- Next : File_Name_Ref;
- end record;
- -- Used to record the names of all Makefiles created, so that we may delete
- -- them if necessary.
-
- File_Names : File_Name_Ref;
- -- List of all the Makefiles created so far.
-
- -----------
- -- Close --
- -----------
-
- procedure Close is
- begin
- Flush;
- Text_IO.Close (File);
-
- exception
- when X : others =>
- Text_IO.Put_Line (Exceptions.Exception_Message (X));
- Osint.Fail ("cannot close a Makefile");
- end Close;
-
- ------------
- -- Create --
- ------------
-
- procedure Create (File_Name : String) is
- begin
- Text_IO.Create (File, Text_IO.Out_File, File_Name);
- Current := 1;
- Lines (1).Length := 0;
- Lines (1).Suppressed := False;
- File_Names :=
- new File_Name_Data'(Value => new String'(File_Name),
- Next => File_Names);
- exception
- when X : others =>
- Text_IO.Put_Line (Exceptions.Exception_Message (X));
- Osint.Fail ("cannot create """ & File_Name & '"');
- end Create;
-
- ----------------
- -- Delete_All --
- ----------------
-
- procedure Delete_All is
- Success : Boolean;
- begin
- if Text_IO.Is_Open (File) then
- Text_IO.Delete (File);
- File_Names := File_Names.Next;
- end if;
-
- while File_Names /= null loop
- Delete_File (File_Names.Value.all, Success);
- File_Names := File_Names.Next;
- end loop;
- end Delete_All;
-
- -----------
- -- Flush --
- -----------
-
- procedure Flush is
- Last : Natural;
- begin
- if Lines (Current).Length /= 0 then
- Osint.Fail ("INTERNAL ERROR: flushing before end of line: """ &
- Lines (Current).Value
- (1 .. Lines (Current).Length));
- end if;
-
- for J in 1 .. Current - 1 loop
- if not Lines (J).Suppressed then
- Last := Lines (J).Length;
-
- -- The last character of a line cannot be a back slash ('\'),
- -- otherwise make has a problem. The only real place were it
- -- should happen is for directory names on Windows, and then
- -- this terminal back slash is not needed.
-
- if Last > 0 and then Lines (J).Value (Last) = '\' then
- Last := Last - 1;
- end if;
-
- Text_IO.Put_Line (File, Lines (J).Value (1 .. Last));
- end if;
- end loop;
-
- Current := 1;
- Lines (1).Length := 0;
- Lines (1).Suppressed := False;
- end Flush;
-
- ----------
- -- Mark --
- ----------
-
- procedure Mark (Pos : out Position) is
- begin
- if Lines (Current).Length /= 0 then
- Osint.Fail ("INTERNAL ERROR: marking before end of line: """ &
- Lines (Current).Value
- (1 .. Lines (Current).Length));
- end if;
-
- Pos := (Value => Current);
- end Mark;
-
- ------------------
- -- Name_Of_File --
- ------------------
-
- function Name_Of_File return String is
- begin
- return Text_IO.Name (File);
- end Name_Of_File;
-
- --------------
- -- New_Line --
- --------------
-
- procedure New_Line is
- begin
- Current := Current + 1;
-
- if Current > Lines'Last then
- declare
- New_Lines : constant Buffer :=
- new Line_Array (1 .. 2 * Lines'Last);
-
- begin
- New_Lines (1 .. Lines'Last) := Lines.all;
- Free (Lines);
- Lines := New_Lines;
- end;
- end if;
-
- Lines (Current).Length := 0;
- Lines (Current).Suppressed := False;
-
- -- Allocate a new line, if necessary
-
- if Lines (Current).Value = null then
- Lines (Current).Value := new String (1 .. Initial_Length_Of_Line);
- end if;
- end New_Line;
-
- ---------
- -- Put --
- ---------
-
- procedure Put (S : String) is
- Length : constant Natural := Lines (Current).Length;
-
- begin
- if Length + S'Length > Lines (Current).Value'Length then
- declare
- New_Line : String_Access;
- New_Length : Positive := 2 * Lines (Current).Value'Length;
- begin
- while Length + S'Length > New_Length loop
- New_Length := 2 * New_Length;
- end loop;
-
- New_Line := new String (1 .. New_Length);
- New_Line (1 .. Length) := Lines (Current).Value (1 .. Length);
- Free (Lines (Current).Value);
- Lines (Current).Value := New_Line;
- end;
- end if;
-
- Lines (Current).Value (Length + 1 .. Length + S'Length) := S;
- Lines (Current).Length := Length + S'Length;
- end Put;
-
- -------------
- -- Release --
- -------------
-
- procedure Release (Pos : Position) is
- begin
- if Lines (Current).Length /= 0 then
- Osint.Fail ("INTERNAL ERROR: releasing before end of line: """ &
- Lines (Current).Value
- (1 .. Lines (Current).Length));
- end if;
-
- if Pos.Value > Current then
- Osint.Fail ("INTERNAL ERROR: releasing ahead of current position");
- end if;
-
- Current := Pos.Value;
- Lines (Current).Length := 0;
- end Release;
-
- --------------
- -- Suppress --
- --------------
-
- procedure Suppress (Pos : Position) is
- begin
- if Pos.Value >= Current then
- Osint.Fail ("INTERNAL ERROR: suppressing ahead of current position");
- end if;
-
- Lines (Pos.Value).Suppressed := True;
- end Suppress;
-
-begin
- -- Allocate the first line.
- -- The other ones are allocated by New_Line.
-
- Lines (1).Value := new String (1 .. Initial_Length_Of_Line);
-end Bld.IO;
diff --git a/gcc/ada/bld-io.ads b/gcc/ada/bld-io.ads
deleted file mode 100644
index c5df6274ad1..00000000000
--- a/gcc/ada/bld-io.ads
+++ /dev/null
@@ -1,73 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- B L D - I O --
--- --
--- S p e c --
--- --
--- 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- The following private package allows the ouput of text to Makefiles
--- though buffers. It is possible to remove some lines from the buffers
--- without putting them effectively in the Makefile.
-
-private package Bld.IO is
-
- procedure Create (File_Name : String);
- -- Create a new Makefile
-
- procedure Flush;
- -- Output all not suppressed lines to the Makefile
-
- procedure Close;
- -- Close the current Makefile
-
- procedure Delete_All;
- -- Delete all the Makefiles that have been created
-
- function Name_Of_File return String;
- -- Return the path name of the current Makefile
-
- type Position is private;
- -- Identification of a line in the Makefile
-
- procedure Mark (Pos : out Position);
- -- Record the current line.
- -- No characters should have been already put on this line.
-
- procedure Release (Pos : Position);
- -- Suppress all line after this one, including this one.
-
- procedure Suppress (Pos : Position);
- -- Suppress a particular line
-
- procedure Put (S : String);
- -- Append a string to the current line
-
- procedure New_Line;
- -- End a line. Go to the next one (initially empty).
-
-private
-
- type Position is record
- Value : Positive := 1;
- end record;
-
-end Bld.IO;
diff --git a/gcc/ada/bld.adb b/gcc/ada/bld.adb
deleted file mode 100644
index e8b5c89eb82..00000000000
--- a/gcc/ada/bld.adb
+++ /dev/null
@@ -1,3622 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- B L D --
--- --
--- B o d y --
--- --
--- Copyright (C) 2002-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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package is still a work in progress.
-
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Strings.Fixed; use Ada.Strings.Fixed;
-
-with Bld.IO;
-with Csets;
-
-with GNAT.HTable;
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.Command_Line; use GNAT.Command_Line;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-
-with Erroutc; use Erroutc;
-with Err_Vars; use Err_Vars;
-with Gnatvsn;
-with Namet; use Namet;
-with Opt; use Opt;
-with Output; use Output;
-with Prj; use Prj;
-with Prj.Com; use Prj.Com;
-with Prj.Err; use Prj.Err;
-with Prj.Part;
-with Prj.Tree; use Prj.Tree;
-with Snames;
-with Table;
-with Types; use Types;
-
-package body Bld is
-
- function "=" (Left, Right : IO.Position) return Boolean
- renames IO."=";
-
- MAKE_ROOT : constant String := "MAKE_ROOT";
-
- Process_All_Project_Files : Boolean := True;
- -- Set to False by command line switch -R
-
- Copyright_Displayed : Boolean := False;
- -- To avoid displaying the Copyright line several times
-
- Usage_Displayed : Boolean := False;
- -- To avoid displaying the usage several times
-
- type Expression_Kind_Type is (Undecided, Static_String, Other);
-
- Expression_Kind : Expression_Kind_Type := Undecided;
- -- After procedure Expression has been called, this global variable
- -- indicates if the expression is a static string or not.
- -- If it is a static string, then Expression_Value (1 .. Expression_Last)
- -- is the static value of the expression.
-
- Expression_Value : String_Access := new String (1 .. 10);
- Expression_Last : Natural := 0;
-
- -- The following variables indicates if the suffixes and the languages
- -- are statically specified and, if they are, their values.
-
- C_Suffix : String_Access := new String (1 .. 10);
- C_Suffix_Last : Natural := 0;
- C_Suffix_Static : Boolean := True;
-
- Cxx_Suffix : String_Access := new String (1 .. 10);
- Cxx_Suffix_Last : Natural := 0;
- Cxx_Suffix_Static : Boolean := True;
-
- Ada_Spec_Suffix : String_Access := new String (1 .. 10);
- Ada_Spec_Suffix_Last : Natural := 0;
- Ada_Spec_Suffix_Static : Boolean := True;
-
- Ada_Body_Suffix : String_Access := new String (1 .. 10);
- Ada_Body_Suffix_Last : Natural := 0;
- Ada_Body_Suffix_Static : Boolean := True;
-
- Languages : String_Access := new String (1 .. 50);
- Languages_Last : Natural := 0;
- Languages_Static : Boolean := True;
-
- type Source_Kind_Type is (Unknown, Ada_Spec, Ada_Body, C, Cxx, None);
- -- Used when post-processing Compiler'Switches to indicate the language
- -- of a source.
-
- -- The following variables are used to controlled what attributes
- -- Default_Switches and Switches are allowed in expressions.
-
- Default_Switches_Package : Name_Id := No_Name;
- Default_Switches_Language : Name_Id := No_Name;
- Switches_Package : Name_Id := No_Name;
- Switches_Language : Source_Kind_Type := Unknown;
-
- -- Other attribute references are only allowed in attribute declarations
- -- of the same package and of the same name.
-
- -- Other_Attribute is True only during attribute declarations other than
- -- Switches or Default_Switches.
-
- Other_Attribute : Boolean := False;
- Other_Attribute_Package : Name_Id := No_Name;
- Other_Attribute_Name : Name_Id := No_Name;
-
- type Declaration_Type is (False, May_Be, True);
-
- Source_Files_Declaration : Declaration_Type := False;
-
- Source_List_File_Declaration : Declaration_Type := False;
-
- -- Names that are not in Snames
-
- Name_Ide : Name_Id := No_Name;
- Name_Compiler_Command : Name_Id := No_Name;
- Name_Main_Language : Name_Id := No_Name;
- Name_C_Plus_Plus : Name_Id := No_Name;
-
- package Processed_Projects is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Project_Node_Id,
- No_Element => Empty_Node,
- Key => Name_Id,
- Hash => Hash,
- Equal => "=");
- -- This hash table contains all processed projects.
- -- It is used to avoid processing the same project file several times.
-
- package Externals is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Natural,
- No_Element => 0,
- Key => Project_Node_Id,
- Hash => Hash,
- Equal => "=");
- -- This hash table is used to store all the external references.
- -- For each project file, the tree is first traversed and all
- -- external references are put in variables. Each of these variables
- -- are identified by a number, so that the can be referred to
- -- later during the second traversal of the tree.
-
- package Variable_Names is new Table.Table
- (Table_Component_Type => Name_Id,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 10,
- Table_Name => "Bld.Variable_Names");
- -- This table stores all the variables declared in a package.
- -- It is used to distinguish project level and package level
- -- variables identified by simple names.
- -- This table is reset for each package.
-
- package Switches is new Table.Table
- (Table_Component_Type => Name_Id,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 10,
- Table_Name => "Bld.Switches");
- -- This table stores all the indexs of associative array attribute
- -- Compiler'Switches specified in a project file. It is reset for
- -- each project file. At the end of processing of a project file
- -- this table is traversed to output targets for those files
- -- that may be C or C++ source files.
-
- Last_External : Natural := 0;
- -- For each external reference, this variable in incremented by 1,
- -- and a Makefile variable <PROJECT>__EXTERNAL__<Last_External> is
- -- declared. See procedure Process_Externals.
-
- Last_Case_Construction : Natural := 0;
- -- For each case construction, this variable is incremented by 1,
- -- and a Makefile variable <PROJECT>__CASE__<Last_Case_Construction> is
- -- declared. See procedure Process_Declarative_Items.
-
- Saved_Suffix : constant String := ".saved";
- -- Prefix to be added to the name of reserved variables (see below) when
- -- used in external references.
-
- -- A number of environment variables, whose names are used in the
- -- Makefiles are saved at the beginning of the main Makefile.
- -- Each reference to any such environment variable is replaced
- -- in the Makefiles with the name of the saved variable.
-
- Ada_Body_String : aliased String := "ADA_BODY";
- Ada_Flags_String : aliased String := "ADA_FLAGS";
- Ada_Mains_String : aliased String := "ADA_MAINS";
- Ada_Sources_String : aliased String := "ADA_SOURCES";
- Ada_Spec_String : aliased String := "ADA_SPEC";
- Ar_Cmd_String : aliased String := "AR_CMD";
- Ar_Ext_String : aliased String := "AR_EXT";
- Base_Dir_String : aliased String := "BASE_DIR";
- Cc_String : aliased String := "CC";
- C_Ext_String : aliased String := "C_EXT";
- Cflags_String : aliased String := "CFLAGS";
- Cxx_String : aliased String := "CXX";
- Cxx_Ext_String : aliased String := "CXX_EXT";
- Cxxflags_String : aliased String := "CXXFLAGS";
- Deps_Projects_String : aliased String := "DEPS_PROJECT";
- Exec_String : aliased String := "EXEC";
- Exec_Dir_String : aliased String := "EXEC_DIR";
- Fldflags_String : aliased String := "FLDFLAGS";
- Gnatmake_String : aliased String := "GNATMAKE";
- Languages_String : aliased String := "LANGUAGES";
- Ld_Flags_String : aliased String := "LD_FLAGS";
- Libs_String : aliased String := "LIBS";
- Main_String : aliased String := "MAIN";
- Obj_Ext_String : aliased String := "OBJ_EXT";
- Obj_Dir_String : aliased String := "OBJ_DIR";
- Project_File_String : aliased String := "PROJECT_FILE";
- Src_Dirs_String : aliased String := "SRC_DIRS";
-
- type Reserved_Variable_Array is array (Positive range <>) of String_Access;
- Reserved_Variables : constant Reserved_Variable_Array :=
- (Ada_Body_String 'Access,
- Ada_Flags_String 'Access,
- Ada_Mains_String 'Access,
- Ada_Sources_String 'Access,
- Ada_Spec_String 'Access,
- Ar_Cmd_String 'Access,
- Ar_Ext_String 'Access,
- Base_Dir_String 'Access,
- Cc_String 'Access,
- C_Ext_String 'Access,
- Cflags_String 'Access,
- Cxx_String 'Access,
- Cxx_Ext_String 'Access,
- Cxxflags_String 'Access,
- Deps_Projects_String'Access,
- Exec_String 'Access,
- Exec_Dir_String 'Access,
- Fldflags_String 'Access,
- Gnatmake_String 'Access,
- Languages_String 'Access,
- Ld_Flags_String 'Access,
- Libs_String 'Access,
- Main_String 'Access,
- Obj_Ext_String 'Access,
- Obj_Dir_String 'Access,
- Project_File_String 'Access,
- Src_Dirs_String 'Access);
-
- Main_Project_File_Name : String_Access;
- -- The name of the main project file, given as argument.
-
- Project_Tree : Project_Node_Id;
- -- The result of the parsing of the main project file.
-
- procedure Add_To_Expression_Value (S : String);
- procedure Add_To_Expression_Value (S : Name_Id);
- -- Add a string to variable Expression_Value
-
- procedure Display_Copyright;
- -- Display name of the tool and the copyright
-
- function Equal_String (Left, Right : Name_Id) return Boolean;
- -- Return True if Left and Right are the same string, without considering
- -- the case.
-
- procedure Expression
- (Project : Project_Node_Id;
- First_Term : Project_Node_Id;
- Kind : Variable_Kind;
- In_Case : Boolean;
- Reset : Boolean := False);
- -- Process an expression.
- -- If In_Case is True, all expressions are not static.
-
- procedure New_Line;
- -- Add a line terminator in the Makefile
-
- procedure Process (Project : Project_Node_Id);
- -- Process the project tree, result of the parsing.
-
- procedure Process_Case_Construction
- (Current_Project : Project_Node_Id;
- Current_Pkg : Name_Id;
- Case_Project : Project_Node_Id;
- Case_Pkg : Name_Id;
- Name : Name_Id;
- Node : Project_Node_Id);
- -- Process a case construction.
- -- The Makefile declations may be suppressed if no declarative
- -- items in the case items are to be put in the Makefile.
-
- procedure Process_Declarative_Items
- (Project : Project_Node_Id;
- Pkg : Name_Id;
- In_Case : Boolean;
- Item : Project_Node_Id);
- -- Process the declarative items for a project, a package
- -- or a case item.
- -- If In_Case is True, all expressions are not static
-
- procedure Process_Externals (Project : Project_Node_Id);
- -- Look for all external references in one project file, populate the
- -- table Externals, and output the necessary declarations, if any.
-
- procedure Put (S : String; With_Substitution : Boolean := False);
- -- Add a string to the Makefile.
- -- When With_Substitution is True, if the string is one of the reserved
- -- variables, replace it with the name of the corresponding saved
- -- variable.
-
- procedure Put (S : Name_Id);
- -- Add a string to the Makefile.
-
- procedure Put (P : Positive);
- -- Add the image of a number to the Makefile, without leading space
-
- procedure Put_Attribute
- (Project : Project_Node_Id;
- Pkg : Name_Id;
- Name : Name_Id;
- Index : Name_Id);
- -- Put the full name of an attribute in the Makefile
-
- procedure Put_Directory_Separator;
- -- Add a directory separator to the Makefile
-
- procedure Put_Include_Project
- (Included_Project_Path : Name_Id;
- Included_Project : Project_Node_Id;
- Including_Project_Name : String);
- -- Output an include directive for a project
-
- procedure Put_Line (S : String);
- -- Add a string and a line terminator to the Makefile
-
- procedure Put_L_Name (N : Name_Id);
- -- Put a name in lower case in the Makefile
-
- procedure Put_M_Name (N : Name_Id);
- -- Put a name in mixed case in the Makefile
-
- procedure Put_U_Name (N : Name_Id);
- -- Put a name in upper case in the Makefile
-
- procedure Special_Put_U_Name (S : Name_Id);
- -- Put a name in upper case in the Makefile.
- -- If "C++" change it to "CXX".
-
- procedure Put_Variable
- (Project : Project_Node_Id;
- Pkg : Name_Id;
- Name : Name_Id);
- -- Put the full name of a variable in the Makefile
-
- procedure Recursive_Process (Project : Project_Node_Id);
- -- Process a project file and the project files it depends on iteratively
- -- without processing twice the same project file.
-
- procedure Reset_Suffixes_And_Languages;
- -- Indicate that all suffixes and languages have the default values
-
- function Source_Kind_Of (File_Name : Name_Id) return Source_Kind_Type;
- -- From a source file name, returns the source kind of the file
-
- function Suffix_Of
- (Static : Boolean;
- Value : String_Access;
- Last : Natural;
- Default : String) return String;
- -- Returns the current suffix, if it is statically known, or ""
- -- if it is not statically known. Used on C_Suffix, Cxx_Suffix,
- -- Ada_Body_Suffix and Ada_Spec_Suffix.
-
- procedure Usage;
- -- Display the usage of gnatbuild
-
- -----------------------------
- -- Add_To_Expression_Value --
- -----------------------------
-
- procedure Add_To_Expression_Value (S : String) is
- begin
- -- Check that the buffer is large enough.
- -- If it is not, double it until it is large enough.
-
- while Expression_Last + S'Length > Expression_Value'Last loop
- declare
- New_Value : constant String_Access :=
- new String (1 .. 2 * Expression_Value'Last);
-
- begin
- New_Value (1 .. Expression_Last) :=
- Expression_Value (1 .. Expression_Last);
- Free (Expression_Value);
- Expression_Value := New_Value;
- end;
- end loop;
-
- Expression_Value (Expression_Last + 1 .. Expression_Last + S'Length)
- := S;
- Expression_Last := Expression_Last + S'Length;
- end Add_To_Expression_Value;
-
- procedure Add_To_Expression_Value (S : Name_Id) is
- begin
- Get_Name_String (S);
- Add_To_Expression_Value (S => Name_Buffer (1 .. Name_Len));
- end Add_To_Expression_Value;
-
- -----------------------
- -- Display_Copyright --
- -----------------------
-
- procedure Display_Copyright is
- begin
- if not Copyright_Displayed then
- Copyright_Displayed := True;
- Write_Str ("GPR2MAKE ");
- Write_Str (Gnatvsn.Gnat_Version_String);
- Write_Str (" Copyright 2002-2004 Free Software Foundation, Inc.");
- Write_Eol;
- Write_Eol;
- end if;
- end Display_Copyright;
-
- ------------------
- -- Equal_String --
- ------------------
-
- function Equal_String (Left, Right : Name_Id) return Boolean is
- begin
- Get_Name_String (Left);
-
- declare
- Left_Value : constant String :=
- To_Lower (Name_Buffer (1 .. Name_Len));
-
- begin
- Get_Name_String (Right);
- return Left_Value = To_Lower (Name_Buffer (1 .. Name_Len));
- end;
- end Equal_String;
-
- ----------------
- -- Expression --
- ----------------
-
- procedure Expression
- (Project : Project_Node_Id;
- First_Term : Project_Node_Id;
- Kind : Variable_Kind;
- In_Case : Boolean;
- Reset : Boolean := False)
- is
- Term : Project_Node_Id := First_Term;
- -- The term in the expression list
-
- Current_Term : Project_Node_Id := Empty_Node;
- -- The current term node id
-
- begin
- if In_Case then
- Expression_Kind := Other;
-
- elsif Reset then
- Expression_Kind := Undecided;
- Expression_Last := 0;
- end if;
-
- while Term /= Empty_Node loop
-
- Current_Term := Tree.Current_Term (Term);
-
- case Kind_Of (Current_Term) is
-
- when N_Literal_String =>
- -- If we are in a string list, we precede this literal string
- -- with a space; it does not matter if the output list
- -- has a leading space.
- -- Otherwise we just output the literal string:
- -- if it is not the first term of the expression, it will
- -- concatenate with was previously output.
-
- if Kind = List then
- Put (" ");
- end if;
-
- -- If in a static string expression, add to expression value
-
- if Expression_Kind = Undecided
- or else Expression_Kind = Static_String
- then
- Expression_Kind := Static_String;
-
- if Kind = List then
- Add_To_Expression_Value (" ");
- end if;
-
- Add_To_Expression_Value (String_Value_Of (Current_Term));
- end if;
-
- Put (String_Value_Of (Current_Term));
-
- when N_Literal_String_List =>
- -- For string list, we repetedly call Expression with each
- -- element of the list.
-
- declare
- String_Node : Project_Node_Id :=
- First_Expression_In_List (Current_Term);
-
- begin
- if String_Node = Empty_Node then
-
- -- If String_Node is nil, it is an empty list,
- -- set Expression_Kind if it is still Undecided
-
- if Expression_Kind = Undecided then
- Expression_Kind := Static_String;
- end if;
-
- else
- Expression
- (Project => Project,
- First_Term => Tree.First_Term (String_Node),
- Kind => Single,
- In_Case => In_Case);
-
- loop
- -- Add the other element of the literal string list
- -- one after the other
-
- String_Node :=
- Next_Expression_In_List (String_Node);
-
- exit when String_Node = Empty_Node;
-
- Put (" ");
- Add_To_Expression_Value (" ");
- Expression
- (Project => Project,
- First_Term => Tree.First_Term (String_Node),
- Kind => Single,
- In_Case => In_Case);
- end loop;
- end if;
- end;
-
- when N_Variable_Reference | N_Attribute_Reference =>
- -- A variable or attribute reference is never static
-
- Expression_Kind := Other;
-
- -- A variable or an attribute is identified by:
- -- - its project name,
- -- - its package name, if any,
- -- - its name, and
- -- - its index (if an associative array attribute).
-
- declare
- Term_Project : Project_Node_Id :=
- Project_Node_Of (Current_Term);
- Term_Package : constant Project_Node_Id :=
- Package_Node_Of (Current_Term);
-
- Name : constant Name_Id := Name_Of (Current_Term);
-
- Term_Package_Name : Name_Id := No_Name;
-
- begin
- if Term_Project = Empty_Node then
- Term_Project := Project;
- end if;
-
- if Term_Package /= Empty_Node then
- Term_Package_Name := Name_Of (Term_Package);
- end if;
-
- -- If we are in a string list, we precede this variable or
- -- attribute reference with a space; it does not matter if
- -- the output list has a leading space.
-
- if Kind = List then
- Put (" ");
- end if;
-
- Put ("$(");
-
- if Kind_Of (Current_Term) = N_Variable_Reference then
- Put_Variable
- (Project => Term_Project,
- Pkg => Term_Package_Name,
- Name => Name);
-
- else
- -- Attribute reference.
-
- -- If it is a Default_Switches attribute, check if it
- -- is allowed in this expression (same package and same
- -- language).
-
- if Name = Snames.Name_Default_Switches then
- if Default_Switches_Package /= Term_Package_Name
- or else not Equal_String
- (Default_Switches_Language,
- Associative_Array_Index_Of
- (Current_Term))
- then
- -- This Default_Switches attribute is not allowed
- -- here; report an error and continue.
- -- The Makefiles created will be deleted at the
- -- end.
-
- Error_Msg_Name_1 := Term_Package_Name;
- Error_Msg
- ("reference to `%''Default_Switches` " &
- "not allowed here",
- Location_Of (Current_Term));
- end if;
-
- -- If it is a Switches attribute, check if it is allowed
- -- in this expression (same package and same source
- -- kind).
-
- elsif Name = Snames.Name_Switches then
- if Switches_Package /= Term_Package_Name
- or else Source_Kind_Of (Associative_Array_Index_Of
- (Current_Term))
- /= Switches_Language
- then
- -- This Switches attribute is not allowed here;
- -- report an error and continue. The Makefiles
- -- created will be deleted at the end.
-
- Error_Msg_Name_1 := Term_Package_Name;
- Error_Msg
- ("reference to `%''Switches` " &
- "not allowed here",
- Location_Of (Current_Term));
- end if;
-
- else
- -- Other attribute references are only allowed in
- -- the declaration of an atribute of the same
- -- package and of the same name.
-
- if not Other_Attribute
- or else Other_Attribute_Package /= Term_Package_Name
- or else Other_Attribute_Name /= Name
- then
- if Term_Package_Name = No_Name then
- Error_Msg_Name_1 := Name;
- Error_Msg
- ("reference to % not allowed here",
- Location_Of (Current_Term));
-
- else
- Error_Msg_Name_1 := Term_Package_Name;
- Error_Msg_Name_2 := Name;
- Error_Msg
- ("reference to `%''%` not allowed here",
- Location_Of (Current_Term));
- end if;
- end if;
- end if;
-
- Put_Attribute
- (Project => Term_Project,
- Pkg => Term_Package_Name,
- Name => Name,
- Index => Associative_Array_Index_Of (Current_Term));
- end if;
-
- Put (")");
- end;
-
- when N_External_Value =>
- -- An external reference is never static
-
- Expression_Kind := Other;
-
- -- As the external references have already been processed,
- -- we just output the name of the variable that corresponds
- -- to this external reference node.
-
- Put ("$(");
- Put_U_Name (Name_Of (Project));
- Put (".external.");
- Put (Externals.Get (Current_Term));
- Put (")");
-
- when others =>
-
- -- Should never happen
-
- pragma Assert
- (False,
- "illegal node kind in an expression");
- raise Program_Error;
- end case;
-
- Term := Next_Term (Term);
- end loop;
- end Expression;
-
- --------------
- -- Gpr2make --
- --------------
-
- procedure Gpr2make is
- begin
- -- First, get the switches, if any
-
- loop
- case Getopt ("h q v R") is
- when ASCII.NUL =>
- exit;
-
- -- -h: Help
-
- when 'h' =>
- Usage;
-
- -- -q: Quiet
-
- when 'q' =>
- Opt.Quiet_Output := True;
-
- -- -v: Verbose
-
- when 'v' =>
- Opt.Verbose_Mode := True;
- Display_Copyright;
-
- -- -R: no Recursivity
-
- when 'R' =>
- Process_All_Project_Files := False;
-
- when others =>
- raise Program_Error;
- end case;
- end loop;
-
- -- Now, get the project file (maximum one)
-
- loop
- declare
- S : constant String := Get_Argument (Do_Expansion => True);
- begin
- exit when S'Length = 0;
-
- if Main_Project_File_Name /= null then
- Fail ("only one project file may be specified");
-
- else
- Main_Project_File_Name := new String'(S);
- end if;
- end;
- end loop;
-
- -- If no project file specified, display the usage and exit
-
- if Main_Project_File_Name = null then
- Usage;
- return;
- end if;
-
- -- Do the necessary initializations
-
- Csets.Initialize;
- Namet.Initialize;
-
- Snames.Initialize;
-
- Prj.Initialize;
-
- -- Parse the project file(s)
-
- Prj.Part.Parse (Project_Tree, Main_Project_File_Name.all, False);
-
- -- If parsing was successful, process the project tree
-
- if Project_Tree /= Empty_Node then
-
- -- Create some Name_Ids that are not in Snames
-
- Name_Len := 3;
- Name_Buffer (1 .. Name_Len) := "ide";
- Name_Ide := Name_Find;
-
- Name_Len := 16;
- Name_Buffer (1 .. Name_Len) := "compiler_command";
- Name_Compiler_Command := Name_Find;
-
- Name_Len := 13;
- Name_Buffer (1 .. Name_Len) := "main_language";
- Name_Main_Language := Name_Find;
-
- Name_Len := 3;
- Name_Buffer (1 .. Name_Len) := "c++";
- Name_C_Plus_Plus := Name_Find;
-
- Process (Project_Tree);
-
- if Compilation_Errors then
- if not Verbose_Mode then
- Write_Eol;
- end if;
-
- Prj.Err.Finalize;
- Write_Eol;
- IO.Delete_All;
- Fail ("no Makefile created");
- end if;
- end if;
- end Gpr2make;
-
- --------------
- -- New_Line --
- --------------
-
- procedure New_Line is
- begin
- IO.New_Line;
- end New_Line;
-
- -------------
- -- Process --
- -------------
-
- procedure Process (Project : Project_Node_Id) is
- begin
- Processed_Projects.Reset;
- Recursive_Process (Project);
- end Process;
-
- -------------------------------
- -- Process_Case_Construction --
- -------------------------------
-
- procedure Process_Case_Construction
- (Current_Project : Project_Node_Id;
- Current_Pkg : Name_Id;
- Case_Project : Project_Node_Id;
- Case_Pkg : Name_Id;
- Name : Name_Id;
- Node : Project_Node_Id)
- is
- Case_Project_Name : constant Name_Id := Name_Of (Case_Project);
- Before : IO.Position;
- Start : IO.Position;
- After : IO.Position;
-
- procedure Put_Case_Construction;
- -- Output the variable $<PROJECT>__CASE__#, specific to
- -- this case construction. It contains the number of the
- -- branch to follow.
-
- procedure Recursive_Process
- (Case_Item : Project_Node_Id;
- Branch_Number : Positive);
- -- A recursive procedure. Calls itself for each branch, increasing
- -- Branch_Number by 1 each time.
-
- procedure Put_Variable_Name;
- -- Output the case variable
-
- ---------------------------
- -- Put_Case_Construction --
- ---------------------------
-
- procedure Put_Case_Construction is
- begin
- Put_U_Name (Case_Project_Name);
- Put (".case.");
- Put (Last_Case_Construction);
- end Put_Case_Construction;
-
- -----------------------
- -- Recursive_Process --
- -----------------------
-
- procedure Recursive_Process
- (Case_Item : Project_Node_Id;
- Branch_Number : Positive)
- is
- Choice_String : Project_Node_Id := First_Choice_Of (Case_Item);
-
- Before : IO.Position;
- Start : IO.Position;
- After : IO.Position;
-
- No_Lines : Boolean := False;
-
- begin
- -- Nothing to do if Case_Item is empty.
- -- That should happen only if the case construvtion is totally empty.
- -- case Var is
- -- end case;
-
- if Case_Item /= Empty_Node then
- -- Remember where we are, to be able to come back here if this
- -- case item is empty.
-
- IO.Mark (Before);
-
- if Choice_String = Empty_Node then
- -- when others =>
-
- -- Output a comment "# when others => ..."
-
- Put_Line ("# when others => ...");
-
- -- Remember where we are, to detect if there is anything
- -- put in the Makefile for this branch.
-
- IO.Mark (Start);
-
- -- Process the declarative items of this branch
-
- Process_Declarative_Items
- (Project => Current_Project,
- Pkg => Current_Pkg,
- In_Case => True,
- Item => First_Declarative_Item_Of (Case_Item));
-
- -- Where are we now?
- IO.Mark (After);
-
- -- If we are at the same place, the branch is totally empty:
- -- suppress it completely.
-
- if Start = After then
- IO.Release (Before);
- end if;
- else
- -- Case Item with one or several case labels
-
- -- Output a comment
- -- # case <label> => ...
- -- or
- -- # case <first_Label> | ... =>
- -- depending on the number of case labels.
-
- Put ("# when """);
- Put (String_Value_Of (Choice_String));
- Put ("""");
-
- if Next_Literal_String (Choice_String) /= Empty_Node then
- Put (" | ...");
- end if;
-
- Put (" => ...");
- New_Line;
-
- -- Check if the case variable is equal to the first case label
- Put ("ifeq ($(");
- Put_Variable_Name;
- Put ("),");
- Put (String_Value_Of (Choice_String));
- Put (")");
- New_Line;
-
- if Next_Literal_String (Choice_String) /= Empty_Node then
- -- Several choice strings. We need to use an auxiliary
- -- variable <PROJECT.case.# to detect if we should follow
- -- this branch.
-
- loop
- Put_Case_Construction;
- Put (":=");
- Put (Branch_Number);
- New_Line;
-
- Put_Line ("endif");
-
- Choice_String := Next_Literal_String (Choice_String);
-
- exit when Choice_String = Empty_Node;
-
- Put ("ifeq ($(");
- Put_Variable_Name;
- Put ("),");
- Put (String_Value_Of (Choice_String));
- Put (")");
- New_Line;
- end loop;
-
- -- Now, we test the auxiliary variable
-
- Put ("ifeq ($(");
- Put_Case_Construction;
- Put ("),");
- Put (Branch_Number);
- Put (")");
- New_Line;
- end if;
-
- -- Remember where we are before calling
- -- Process_Declarative_Items.
-
- IO.Mark (Start);
-
- Process_Declarative_Items
- (Project => Current_Project,
- Pkg => Current_Pkg,
- In_Case => True,
- Item => First_Declarative_Item_Of (Case_Item));
-
- -- Check where we are now, to detect if some lines have been
- -- added to the Makefile.
-
- IO.Mark (After);
-
- No_Lines := Start = After;
-
- -- If no lines have been added, then suppress completely this
- -- branch.
-
- if No_Lines then
- IO.Release (Before);
- end if;
-
- -- If there is a next branch, process it
-
- if Next_Case_Item (Case_Item) /= Empty_Node then
- -- If this branch has not been suppressed, we need an "else"
-
- if not No_Lines then
- -- Mark the position of the "else"
-
- IO.Mark (Before);
-
- Put_Line ("else");
-
- -- Mark the position before the next branch
-
- IO.Mark (Start);
- end if;
-
- Recursive_Process
- (Case_Item => Next_Case_Item (Case_Item),
- Branch_Number => Branch_Number + 1);
-
- if not No_Lines then
- -- Where are we?
- IO.Mark (After);
-
- -- If we are at the same place, suppress the useless
- -- "else".
-
- if After = Start then
- IO.Release (Before);
- end if;
- end if;
- end if;
-
- -- If the branch has not been suppressed, we need an "endif"
-
- if not No_Lines then
- Put_Line ("endif");
- end if;
- end if;
- end if;
- end Recursive_Process;
-
- -----------------------
- -- Put_Variable_Name --
- -----------------------
-
- procedure Put_Variable_Name is
- begin
- Put_Variable (Case_Project, Case_Pkg, Name);
- end Put_Variable_Name;
-
- -- Start of procedure Process_Case_Construction
-
- begin
- Last_Case_Construction := Last_Case_Construction + 1;
-
- -- Remember where we are in case we suppress completely the case
- -- construction.
-
- IO.Mark (Before);
-
- New_Line;
-
- -- Output a comment line for this case construction
-
- Put ("# case ");
- Put_M_Name (Case_Project_Name);
-
- if Case_Pkg /= No_Name then
- Put (".");
- Put_M_Name (Case_Pkg);
- end if;
-
- Put (".");
- Put_M_Name (Name);
- Put (" is ...");
- New_Line;
-
- -- Remember where we are, to detect if all branches have been suppressed
-
- IO.Mark (Start);
-
- -- Start at the first case item
-
- Recursive_Process
- (Case_Item => First_Case_Item_Of (Node),
- Branch_Number => 1);
-
- -- Where are we?
-
- IO.Mark (After);
-
- -- If we are at the same position, it means that all branches have been
- -- suppressed: then we suppress completely the case construction.
-
- if Start = After then
- IO.Release (Before);
-
- else
- -- If the case construction is not completely suppressed, we issue
- -- a comment indicating the end of the case construction.
-
- Put_Line ("# end case;");
-
- New_Line;
- end if;
- end Process_Case_Construction;
-
- -------------------------------
- -- Process_Declarative_Items --
- -------------------------------
-
- procedure Process_Declarative_Items
- (Project : Project_Node_Id;
- Pkg : Name_Id;
- In_Case : Boolean;
- Item : Project_Node_Id)
- is
- Current_Declarative_Item : Project_Node_Id := Item;
- Current_Item : Project_Node_Id := Empty_Node;
-
- Project_Name : constant String :=
- To_Upper (Get_Name_String (Name_Of (Project)));
- Item_Name : Name_Id := No_Name;
-
- begin
- -- For each declarative item
-
- while Current_Declarative_Item /= Empty_Node loop
- -- Get its data
-
- Current_Item := Current_Item_Node (Current_Declarative_Item);
-
- -- And set Current_Declarative_Item to the next declarative item
- -- ready for the next iteration
-
- Current_Declarative_Item := Next_Declarative_Item
- (Current_Declarative_Item);
-
- -- By default, indicate that we are not declaring attribute
- -- Default_Switches or Switches.
-
- Other_Attribute := False;
-
- -- Write_Line (Project_Node_Kind'Image (Kind_Of (Current_Item)));
-
- case Kind_Of (Current_Item) is
-
- when N_Package_Declaration =>
- Item_Name := Name_Of (Current_Item);
-
- declare
- Real_Project : constant Project_Node_Id :=
- Project_Of_Renamed_Package_Of
- (Current_Item);
-
- Before_Package : IO.Position;
- Start_Of_Package : IO.Position;
- End_Of_Package : IO.Position;
-
- Decl_Item : Project_Node_Id;
-
- begin
- -- If it is a renaming package, we go to the original
- -- package. This is guaranteed to work, otherwise the
- -- parsing of the project file tree would have already
- -- failed.
-
- if Real_Project /= Empty_Node then
- Decl_Item :=
- First_Declarative_Item_Of
- (Project_Declaration_Of (Real_Project));
-
- -- Traverse the declarative items of the project,
- -- until we find the renamed package.
-
- while Decl_Item /= Empty_Node loop
- Current_Item := Current_Item_Node (Decl_Item);
- exit when Kind_Of (Current_Item)
- = N_Package_Declaration
- and then Name_Of (Current_Item) = Item_Name;
- Decl_Item := Next_Declarative_Item (Decl_Item);
- end loop;
- end if;
-
- -- Remember where we are, in case we want to completely
- -- suppress this package.
-
- IO.Mark (Before_Package);
-
- New_Line;
-
- -- Output comment line for this package
-
- Put ("# package ");
- Put_M_Name (Item_Name);
- Put (" is ...");
- New_Line;
-
- -- Record where we are before calling
- -- Process_Declarative_Items.
-
- IO.Mark (Start_Of_Package);
-
- -- And process the declarative items of this package
-
- Process_Declarative_Items
- (Project => Project,
- Pkg => Item_Name,
- In_Case => False,
- Item => First_Declarative_Item_Of (Current_Item));
-
- -- Reset the local variables once we have finished with
- -- this package.
-
- Variable_Names.Init;
-
- -- Where are we?
- IO.Mark (End_Of_Package);
-
- -- If we are at the same place, suppress completely the
- -- package.
-
- if End_Of_Package = Start_Of_Package then
- IO.Release (Before_Package);
-
- else
-
- -- otherwise, utput comment line for end of package
-
- Put ("# end ");
- Put_M_Name (Item_Name);
- Put (";");
- New_Line;
-
- New_Line;
- end if;
- end;
-
- when N_Variable_Declaration | N_Typed_Variable_Declaration =>
- Item_Name := Name_Of (Current_Item);
-
- -- Output comment line for this variable
-
- Put ("# ");
- Put_M_Name (Item_Name);
- Put (" := ...");
- New_Line;
-
- -- If we are inside a package, the variable is a local
- -- variable, not a project level variable.
- -- So we check if its name is included in the Variables
- -- table; if it is not already, we put it in the table.
-
- if Pkg /= No_Name then
- declare
- Found : Boolean := False;
-
- begin
- for
- Index in Variable_Names.First .. Variable_Names.Last
- loop
- if Variable_Names.Table (Index) = Item_Name then
- Found := True;
- exit;
- end if;
- end loop;
-
- if not Found then
- Variable_Names.Increment_Last;
- Variable_Names.Table (Variable_Names.Last) :=
- Item_Name;
- end if;
- end;
- end if;
-
- -- Output the line <variable_Name>:=<expression>
-
- Put_Variable (Project, Pkg, Item_Name);
-
- Put (":=");
-
- Expression
- (Project => Project,
- First_Term => Tree.First_Term (Expression_Of (Current_Item)),
- Kind => Expression_Kind_Of (Current_Item),
- In_Case => In_Case);
-
- New_Line;
-
- when N_Attribute_Declaration =>
- Item_Name := Name_Of (Current_Item);
-
- declare
- Index : constant Name_Id :=
- Associative_Array_Index_Of (Current_Item);
-
- Pos_Comment : IO.Position;
- Put_Declaration : Boolean := True;
-
- begin
- -- If it is a Default_Switches attribute register the
- -- project, the package and the language to indicate
- -- what Default_Switches attribute references are allowed
- -- in expressions.
-
- if Item_Name = Snames.Name_Default_Switches then
- Default_Switches_Package := Pkg;
- Default_Switches_Language := Index;
-
- -- If it is a Switches attribute register the project,
- -- the package and the source kind to indicate what
- -- Switches attribute references are allowed in expressions.
-
- elsif Item_Name = Snames.Name_Switches then
- Switches_Package := Pkg;
- Switches_Language := Source_Kind_Of (Index);
-
- else
- -- Set Other_Attribute to True to indicate that we are
- -- in the declaration of an attribute other than
- -- Switches or Default_Switches.
-
- Other_Attribute := True;
- Other_Attribute_Package := Pkg;
- Other_Attribute_Name := Item_Name;
- end if;
-
- -- Record where we are to be able to suppress the
- -- declaration.
-
- IO.Mark (Pos_Comment);
-
- -- Output comment line for this attribute
-
- Put ("# for ");
- Put_M_Name (Item_Name);
-
- if Index /= No_Name then
- Put (" (""");
- Put (Index);
- Put (""")");
- end if;
-
- Put (" use ...");
- New_Line;
-
- -- Output the line <attribute_name>:=<expression>
-
- Put_Attribute (Project, Pkg, Item_Name, Index);
- Put (":=");
- Expression
- (Project => Project,
- First_Term =>
- Tree.First_Term (Expression_Of (Current_Item)),
- Kind => Expression_Kind_Of (Current_Item),
- In_Case => In_Case,
- Reset => True);
- New_Line;
-
- -- Remove any Default_Switches attribute declaration for
- -- languages other than C or C++.
-
- if Item_Name = Snames.Name_Default_Switches then
- Get_Name_String (Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Put_Declaration :=
- Name_Buffer (1 .. Name_Len) = "c" or else
- Name_Buffer (1 .. Name_Len) = "c++";
-
- -- Remove any Switches attribute declaration for source
- -- kinds other than C, C++ or unknown.
-
- elsif Item_Name = Snames.Name_Switches then
- Put_Declaration :=
- Switches_Language = Unknown
- or else Switches_Language = C
- or else Switches_Language = Cxx;
-
- end if;
-
- -- Attributes in packages other than Naming, Compiler or
- -- IDE are of no interest; suppress their declarations.
-
- Put_Declaration := Put_Declaration and
- (Pkg = No_Name
- or else Pkg = Snames.Name_Naming
- or else Pkg = Snames.Name_Compiler
- or else Pkg = Name_Ide
- or else Pkg = Snames.Name_Linker);
-
- if Put_Declaration then
- -- Some attributes are converted into reserved variables
-
- if Pkg = No_Name then
-
- -- Project level attribute
-
- if Item_Name = Snames.Name_Languages then
-
- -- for Languages use ...
-
- -- Attribute Languages is converted to variable
- -- LANGUAGES. The actual string is put in lower
- -- case.
-
- Put ("LANGUAGES:=");
-
- -- If the expression is static (expected to be so
- -- most of the cases), then just give to LANGUAGES
- -- the lower case value of the expression.
-
- if Expression_Kind = Static_String then
- Put (To_Lower (Expression_Value
- (1 .. Expression_Last)));
-
- else
- -- Otherwise, call to_lower on the value
- -- of the attribute.
-
- Put ("$(shell gprcmd to_lower $(");
- Put_Attribute
- (Project, No_Name, Item_Name, No_Name);
- Put ("))");
- end if;
-
- New_Line;
-
- -- Record value of Languages if expression is
- -- static and if Languages_Static is True.
-
- if Expression_Kind /= Static_String then
- Languages_Static := False;
-
- elsif Languages_Static then
- To_Lower
- (Expression_Value (1 .. Expression_Last));
-
- if Languages_Last = 0 then
- if Languages'Last < Expression_Last + 2 then
- Free (Languages);
- Languages :=
- new String (1 .. Expression_Last + 2);
- end if;
-
- Languages (1) := ' ';
- Languages (2 .. Expression_Last + 1) :=
- Expression_Value (1 .. Expression_Last);
- Languages_Last := Expression_Last + 2;
- Languages (Languages_Last) := ' ';
-
- else
- Languages_Static :=
- Languages (2 .. Languages_Last - 1) =
- Expression_Value (1 .. Expression_Last);
- end if;
- end if;
-
- elsif Item_Name = Snames.Name_Source_Dirs then
-
- -- for Source_Dirs use ...
-
- -- String list attribute Source_Dirs is converted
- -- to variable <PROJECT>.src_dirs, each element
- -- being an absolute directory name.
-
- Put (Project_Name &
- ".src_dirs:=$(foreach name,$(");
- Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put ("),$(shell gprcmd extend $(");
- Put (Project_Name);
- Put_Line (".base_dir) '""$(name)""'))");
-
- elsif Item_Name = Snames.Name_Source_Files then
-
- -- for Source_Files use ...
-
- -- String list Source_Files is converted to
- -- variable <PROJECT>.src_files
-
- Put (Project_Name);
- Put (".src_files:=$(");
- Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put (")");
- New_Line;
-
- if In_Case then
- if Source_Files_Declaration = False then
- Source_Files_Declaration := May_Be;
- end if;
-
- if Source_Files_Declaration /= True then
-
- -- Variable src_files.specified is set to
- -- TRUE. It will be tested to decide if there
- -- is a need to look for source files either
- -- in the source directories or in a source
- -- list file.
-
- Put_Line ("src_files.specified:=TRUE");
- end if;
-
- else
- Source_Files_Declaration := True;
- end if;
-
- elsif Item_Name = Snames.Name_Source_List_File then
-
- -- for Source_List_File use ...
-
- -- Single string Source_List_File is converted to
- -- variable src.list_file. It will be used
- -- later, if necessary, to get the source
- -- file names from the specified file.
- -- The file name is converted to an absolute path
- -- name if necessary.
-
- Put ("src.list_file:=" &
- "$(strip $(shell gprcmd to_absolute $(");
- Put (Project_Name);
- Put (".base_dir) '$(");
- Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")'))");
-
- if In_Case then
- if Source_List_File_Declaration = False then
- Source_List_File_Declaration := May_Be;
- end if;
-
- if Source_Files_Declaration /= True
- and then Source_List_File_Declaration /= True
- then
- -- Variable src_list_file.specified is set to
- -- TRUE. It will be tested later, if
- -- necessary, to read the source list file.
-
- Put_Line ("src_list_file.specified:=TRUE");
- end if;
-
- else
- Source_List_File_Declaration := True;
- end if;
-
- elsif Item_Name = Snames.Name_Object_Dir then
-
- -- for Object_Dir use ...
-
- -- Single string attribute Object_Dir is converted
- -- to variable <PROJECT>.obj_dir. The directory is
- -- converted to an absolute path name,
- -- if necessary.
-
- Put (Project_Name);
- Put (".obj_dir:=" &
- "$(strip $(shell gprcmd to_absolute $(");
- Put (Project_Name);
- Put (".base_dir) '$(");
- Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")'))");
-
- elsif Item_Name = Snames.Name_Exec_Dir then
-
- -- for Exec_Dir use ...
-
- -- Single string attribute Exec_Dir is converted
- -- to variable EXEC_DIR. The directory is
- -- converted to an absolute path name,
- -- if necessary.
-
- Put ("EXEC_DIR:=" &
- "$(strip $(shell gprcmd to_absolute $(");
- Put (Project_Name);
- Put (".base_dir) '$(");
- Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")'))");
-
- elsif Item_Name = Snames.Name_Main then
-
- -- for Mains use ...
-
- -- String list attribute Main is converted to
- -- variable ADA_MAINS.
-
- Put ("ADA_MAINS:=$(");
- Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put (")");
- New_Line;
-
- elsif Item_Name = Name_Main_Language then
-
- -- for Main_Language use ...
-
- Put ("MAIN:=");
-
- -- If the expression is static (expected to be so
- -- most of the cases), then just give to MAIN
- -- the lower case value of the expression.
-
- if Expression_Kind = Static_String then
- Put (To_Lower (Expression_Value
- (1 .. Expression_Last)));
-
- else
- -- Otherwise, call to_lower on the value
- -- of the attribute.
-
- Put ("$(shell gprcmd to_lower $(");
- Put_Attribute
- (Project, No_Name, Item_Name, No_Name);
- Put ("))");
- end if;
-
- New_Line;
-
- else
- -- Other attribute are of no interest; suppress
- -- their declarations.
-
- Put_Declaration := False;
- end if;
-
- elsif Pkg = Snames.Name_Compiler then
- -- Attribute of package Compiler
-
- if Item_Name = Snames.Name_Switches then
-
- -- for Switches (<file_name>) use ...
-
- -- As the C and C++ extension may not be known
- -- statically, at the end of the processing of this
- -- project file, a test will done to decide if the
- -- file name (the index) has a C or C++ extension.
- -- The index is recorded in the table Switches,
- -- making sure that it appears only once.
-
- declare
- Found : Boolean := False;
- begin
- for J in Switches.First .. Switches.Last loop
- if Switches.Table (J) = Index then
- Found := True;
- exit;
- end if;
- end loop;
-
- if not Found then
- Switches.Increment_Last;
- Switches.Table (Switches.Last) := Index;
- end if;
- end;
-
- elsif Item_Name = Snames.Name_Default_Switches then
- Get_Name_String (Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
-
- if Name_Buffer (1 .. Name_Len) = "c" then
- Put ("CFLAGS:=$(");
- Put_Attribute (Project, Pkg, Item_Name, Index);
- Put (")");
- New_Line;
-
- elsif Name_Buffer (1 .. Name_Len) = "c++" then
- Put ("CXXFLAGS:=$(");
- Put_Attribute (Project, Pkg, Item_Name, Index);
- Put (")");
- New_Line;
- end if;
- else
- -- Other attribute are of no interest; suppress
- -- their declarations.
-
- Put_Declaration := False;
- end if;
-
- elsif Pkg = Name_Ide then
-
- -- Attributes of package IDE
-
- if Item_Name = Name_Compiler_Command then
-
- -- for Compiler_Command (<language>) use ...
-
- declare
- Index_Name : Name_Id := No_Name;
-
- begin
- Get_Name_String (Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Index_Name := Name_Find;
-
- -- Only "Ada", "C" and "C++" are of interest
-
- if Index_Name = Snames.Name_Ada then
-
- -- For "Ada", we set the variable $GNATMAKE
-
- Put ("GNATMAKE:=$(");
- Put_Attribute
- (Project, Pkg, Item_Name, Index);
- Put (")");
- New_Line;
-
- elsif Index_Name = Snames.Name_C then
-
- -- For "C", we set the variable $CC
-
- Put ("CC:=$(");
- Put_Attribute
- (Project, Pkg, Item_Name, Index);
- Put (")");
- New_Line;
-
- elsif Index_Name = Name_C_Plus_Plus then
-
- -- For "C++", we set the variable $CXX
-
- Put ("CXX:=$(");
- Put_Attribute
- (Project, Pkg, Item_Name, Index);
- Put (")");
- New_Line;
- end if;
- end;
- else
- -- Other attribute are of no interest; suppress
- -- their declarations.
-
- Put_Declaration := False;
- end if;
-
- elsif Pkg = Snames.Name_Naming then
- -- Attributes of package Naming
-
- if Item_Name = Snames.Name_Body_Suffix then
-
- -- for Body_Suffix (<language>) use ...
-
- declare
- Index_Name : Name_Id := No_Name;
-
- begin
- Get_Name_String (Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Index_Name := Name_Find;
-
- -- Languages "C", "C++" & "Ada" are of interest
-
- if Index_Name = Snames.Name_C then
-
- -- For "C", we set the variable C_EXT
-
- Put ("C_EXT:=$(");
- Put_Attribute
- (Project, Pkg, Item_Name, Index);
- Put (")");
- New_Line;
-
- if Expression_Kind /= Static_String then
- C_Suffix_Static := False;
-
- elsif C_Suffix_Static then
- if C_Suffix_Last = 0 then
- if C_Suffix'Last < Expression_Last then
- Free (C_Suffix);
- C_Suffix := new String'
- (Expression_Value
- (1 .. Expression_Last));
-
- else
- C_Suffix (1 .. Expression_Last) :=
- Expression_Value
- (1 .. Expression_Last);
- end if;
-
- C_Suffix_Last := Expression_Last;
-
- else
- C_Suffix_Static :=
- Expression_Value
- (1 .. Expression_Last) =
- C_Suffix (1 .. C_Suffix_Last);
- end if;
- end if;
-
- elsif Index_Name = Name_C_Plus_Plus then
-
- -- For "C++", we set the variable CXX_EXT
-
- Put ("CXX_EXT:=$(");
- Put_Attribute
- (Project, Pkg, Item_Name, Index);
- Put (")");
- New_Line;
-
- if Expression_Kind /= Static_String then
- Cxx_Suffix_Static := False;
-
- elsif Cxx_Suffix_Static then
- if Cxx_Suffix_Last = 0 then
- if
- Cxx_Suffix'Last < Expression_Last
- then
- Free (Cxx_Suffix);
- Cxx_Suffix := new String'
- (Expression_Value
- (1 .. Expression_Last));
-
- else
- Cxx_Suffix (1 .. Expression_Last) :=
- Expression_Value
- (1 .. Expression_Last);
- end if;
-
- Cxx_Suffix_Last := Expression_Last;
-
- else
- Cxx_Suffix_Static :=
- Expression_Value
- (1 .. Expression_Last) =
- Cxx_Suffix (1 .. Cxx_Suffix_Last);
- end if;
- end if;
-
- elsif Index_Name = Snames.Name_Ada then
-
- -- For "Ada", we set the variable ADA_BODY
-
- Put ("ADA_BODY:=$(");
- Put_Attribute
- (Project, Pkg, Item_Name, Index);
- Put (")");
- New_Line;
-
- if Expression_Kind /= Static_String then
- Ada_Body_Suffix_Static := False;
-
- elsif Ada_Body_Suffix_Static then
- if Ada_Body_Suffix_Last = 0 then
- if
- Ada_Body_Suffix'Last < Expression_Last
- then
- Free (Ada_Body_Suffix);
- Ada_Body_Suffix := new String'
- (Expression_Value
- (1 .. Expression_Last));
-
- else
- Ada_Body_Suffix
- (1 .. Expression_Last) :=
- Expression_Value
- (1 .. Expression_Last);
- end if;
-
- Ada_Body_Suffix_Last := Expression_Last;
-
- else
- Ada_Body_Suffix_Static :=
- Expression_Value
- (1 .. Expression_Last) =
- Ada_Body_Suffix
- (1 .. Ada_Body_Suffix_Last);
- end if;
- end if;
- end if;
- end;
-
- elsif Item_Name = Snames.Name_Spec_Suffix then
-
- -- for Spec_Suffix (<language>) use ...
-
- declare
- Index_Name : Name_Id := No_Name;
-
- begin
- Get_Name_String (Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Index_Name := Name_Find;
-
- -- Only "Ada" is of interest
-
- if Index_Name = Snames.Name_Ada then
-
- -- For "Ada", we set the variable ADA_SPEC
-
- Put ("ADA_SPEC:=$(");
- Put_Attribute
- (Project, Pkg, Item_Name, Index);
- Put (")");
- New_Line;
-
- if Expression_Kind /= Static_String then
- Ada_Spec_Suffix_Static := False;
-
- elsif Ada_Spec_Suffix_Static then
- if Ada_Spec_Suffix_Last = 0 then
- if
- Ada_Spec_Suffix'Last < Expression_Last
- then
- Free (Ada_Spec_Suffix);
- Ada_Spec_Suffix := new String'
- (Expression_Value
- (1 .. Expression_Last));
-
- else
- Ada_Spec_Suffix
- (1 .. Expression_Last) :=
- Expression_Value
- (1 .. Expression_Last);
- end if;
-
- Ada_Spec_Suffix_Last := Expression_Last;
-
- else
- Ada_Spec_Suffix_Static :=
- Expression_Value
- (1 .. Expression_Last) =
- Ada_Spec_Suffix
- (1 .. Ada_Spec_Suffix_Last);
- end if;
- end if;
- end if;
- end;
-
- else
- -- Other attribute are of no interest; suppress
- -- their declarations.
-
- Put_Declaration := False;
- end if;
-
- elsif Pkg = Snames.Name_Linker then
- if Item_Name = Snames.Name_Linker_Options then
-
- -- Only add linker options if this is not the
- -- root project.
-
- Put ("ifeq ($(");
- Put (Project_Name);
- Put (".root),False)");
- New_Line;
-
- -- Add linker options to FLDFLAGS in reverse order
-
- Put (" FLDFLAGS:=$(shell gprcmd linkopts $(");
- Put (Project_Name);
- Put (".base_dir) $(");
- Put_Attribute
- (Project, Pkg, Item_Name, No_Name);
- Put (")) $(FLDFLAGS)");
- New_Line;
-
- Put ("endif");
- New_Line;
-
- -- Other attributes are of no interest. Suppress
- -- their declarations.
-
- else
- Put_Declaration := False;
- end if;
- end if;
- end if;
-
- -- Suppress the attribute declaration if not needed
-
- if not Put_Declaration then
- IO.Release (Pos_Comment);
- end if;
- end;
-
- when N_Case_Construction =>
-
- -- case <typed_string_variable> is ...
-
- declare
- Case_Project : Project_Node_Id := Project;
- Case_Pkg : Name_Id := No_Name;
- Variable_Node : constant Project_Node_Id :=
- Case_Variable_Reference_Of (Current_Item);
- Variable_Name : constant Name_Id := Name_Of (Variable_Node);
-
- begin
- if Project_Node_Of (Variable_Node) /= Empty_Node then
- Case_Project := Project_Node_Of (Variable_Node);
- end if;
-
- if Package_Node_Of (Variable_Node) /= Empty_Node then
- Case_Pkg := Name_Of (Package_Node_Of (Variable_Node));
- end if;
-
- -- If we are in a package, and no package is specified
- -- for the case variable, we look into the table
- -- Variables_Names to decide if it is a variable local
- -- to the package or a project level variable.
-
- if Pkg /= No_Name
- and then Case_Pkg = No_Name
- and then Case_Project = Project
- then
- for
- Index in Variable_Names.First .. Variable_Names.Last
- loop
- if Variable_Names.Table (Index) = Variable_Name then
- Case_Pkg := Pkg;
- exit;
- end if;
- end loop;
- end if;
-
- -- The real work is done in Process_Case_Construction.
-
- Process_Case_Construction
- (Current_Project => Project,
- Current_Pkg => Pkg,
- Case_Project => Case_Project,
- Case_Pkg => Case_Pkg,
- Name => Variable_Name,
- Node => Current_Item);
- end;
-
- when others =>
- null;
-
- end case;
- end loop;
- end Process_Declarative_Items;
-
- -----------------------
- -- Process_Externals --
- -----------------------
- procedure Process_Externals (Project : Project_Node_Id) is
- Project_Name : constant Name_Id := Name_Of (Project);
-
- No_External_Yet : Boolean := True;
-
- procedure Expression (First_Term : Project_Node_Id);
- -- Look for external reference in the term of an expression.
- -- If one is found, build the Makefile external reference variable.
-
- procedure Process_Declarative_Items (Item : Project_Node_Id);
- -- Traverse the declarative items of a project file to find all
- -- external references.
-
- ----------------
- -- Expression --
- ----------------
-
- procedure Expression (First_Term : Project_Node_Id) is
- Term : Project_Node_Id := First_Term;
- -- The term in the expression list
-
- Current_Term : Project_Node_Id := Empty_Node;
- -- The current term node id
-
- Default : Project_Node_Id;
-
- begin
- -- Check each term of the expression
-
- while Term /= Empty_Node loop
- Current_Term := Tree.Current_Term (Term);
-
- if Kind_Of (Current_Term) = N_External_Value then
-
- -- If it is the first external reference of this project file,
- -- output a comment
-
- if No_External_Yet then
- No_External_Yet := False;
- New_Line;
-
- Put_Line ("# external references");
-
- New_Line;
- end if;
-
- -- Increase Last_External and record the node of the external
- -- reference in table Externals, so that the external reference
- -- variable can be identified later.
-
- Last_External := Last_External + 1;
- Externals.Set (Current_Term, Last_External);
-
- Default := External_Default_Of (Current_Term);
-
- Get_Name_String
- (String_Value_Of (External_Reference_Of (Current_Term)));
-
- declare
- External_Name : constant String :=
- Name_Buffer (1 .. Name_Len);
-
- begin
- -- Output a comment for this external reference
-
- Put ("# external (""");
- Put (External_Name);
-
- if Default /= Empty_Node then
- Put (""", """);
- Put (String_Value_Of (Default));
- end if;
-
- Put (""")");
- New_Line;
-
- -- If there is no default, output one line:
-
- -- <PROJECT>__EXTERNAL__#:=$(<external name>)
-
- if Default = Empty_Node then
- Put_U_Name (Project_Name);
- Put (".external.");
- Put (Last_External);
- Put (":=$(");
- Put (External_Name, With_Substitution => True);
- Put (")");
- New_Line;
-
- else
- -- When there is a default, output the following lines:
-
- -- ifeq ($(<external_name),)
- -- <PROJECT>__EXTERNAL__#:=<default>
- -- else
- -- <PROJECT>__EXTERNAL__#:=$(<external_name>)
- -- endif
-
- Put ("ifeq ($(");
- Put (External_Name, With_Substitution => True);
- Put ("),)");
- New_Line;
-
- Put (" ");
- Put_U_Name (Project_Name);
- Put (".external.");
- Put (Last_External);
- Put (":=");
- Put (String_Value_Of (Default));
- New_Line;
-
- Put_Line ("else");
-
- Put (" ");
- Put_U_Name (Project_Name);
- Put (".external.");
- Put (Last_External);
- Put (":=$(");
- Put (External_Name, With_Substitution => True);
- Put (")");
- New_Line;
-
- Put_Line ("endif");
- end if;
- end;
- end if;
-
- Term := Next_Term (Term);
- end loop;
- end Expression;
-
- -------------------------------
- -- Process_Declarative_Items --
- -------------------------------
-
- procedure Process_Declarative_Items (Item : Project_Node_Id) is
- Current_Declarative_Item : Project_Node_Id := Item;
- Current_Item : Project_Node_Id := Empty_Node;
-
- begin
- -- For each declarative item
-
- while Current_Declarative_Item /= Empty_Node loop
- Current_Item := Current_Item_Node (Current_Declarative_Item);
-
- -- Set Current_Declarative_Item to the next declarative item
- -- ready for the next iteration
-
- Current_Declarative_Item := Next_Declarative_Item
- (Current_Declarative_Item);
-
- -- Write_Line (Project_Node_Kind'Image (Kind_Of (Current_Item)));
-
- case Kind_Of (Current_Item) is
-
- when N_Package_Declaration =>
-
- -- Recursive call the declarative items of a package
-
- if
- Project_Of_Renamed_Package_Of (Current_Item) = Empty_Node
- then
- Process_Declarative_Items
- (First_Declarative_Item_Of (Current_Item));
- end if;
-
- when N_Attribute_Declaration |
- N_Typed_Variable_Declaration |
- N_Variable_Declaration =>
-
- -- Process the expression to look for external references
-
- Expression
- (First_Term => Tree.First_Term
- (Expression_Of (Current_Item)));
-
- when N_Case_Construction =>
-
- -- Recursive calls to process the declarative items of
- -- each case item.
-
- declare
- Case_Item : Project_Node_Id :=
- First_Case_Item_Of (Current_Item);
-
- begin
- while Case_Item /= Empty_Node loop
- Process_Declarative_Items
- (First_Declarative_Item_Of (Case_Item));
- Case_Item := Next_Case_Item (Case_Item);
- end loop;
- end;
-
- when others =>
- null;
- end case;
- end loop;
- end Process_Declarative_Items;
-
- -- Start of procedure Process_Externals
-
- begin
- Process_Declarative_Items
- (First_Declarative_Item_Of (Project_Declaration_Of (Project)));
-
- if not No_External_Yet then
- Put_Line ("# end of external references");
- New_Line;
- end if;
- end Process_Externals;
-
- ---------
- -- Put --
- ---------
-
- procedure Put (S : String; With_Substitution : Boolean := False) is
- begin
- IO.Put (S);
-
- -- If With_Substitution is True, check if S is one of the reserved
- -- variables. If it is, append to it the Saved_Suffix.
-
- if With_Substitution then
- for J in Reserved_Variables'Range loop
- if S = Reserved_Variables (J).all then
- IO.Put (Saved_Suffix);
- exit;
- end if;
- end loop;
- end if;
- end Put;
-
- procedure Put (P : Positive) is
- Image : constant String := P'Img;
-
- begin
- Put (Image (Image'First + 1 .. Image'Last));
- end Put;
-
- procedure Put (S : Name_Id) is
- begin
- Get_Name_String (S);
- Put (Name_Buffer (1 .. Name_Len));
- end Put;
-
- -------------------
- -- Put_Attribute --
- -------------------
-
- procedure Put_Attribute
- (Project : Project_Node_Id;
- Pkg : Name_Id;
- Name : Name_Id;
- Index : Name_Id)
- is
- begin
- Put_U_Name (Name_Of (Project));
-
- if Pkg /= No_Name then
- Put (".");
- Put_L_Name (Pkg);
- end if;
-
- Put (".");
- Put_L_Name (Name);
-
- if Index /= No_Name then
- Put (".");
-
- -- For attribute Switches, we don't want to change the file name
-
- if Name = Snames.Name_Switches then
- Get_Name_String (Index);
- Put (Name_Buffer (1 .. Name_Len));
-
- else
- Special_Put_U_Name (Index);
- end if;
- end if;
- end Put_Attribute;
-
- -----------------------------
- -- Put_Directory_Separator --
- -----------------------------
-
- procedure Put_Directory_Separator is
- begin
- Put (S => (1 => Directory_Separator));
- end Put_Directory_Separator;
-
- -------------------------
- -- Put_Include_Project --
- -------------------------
-
- procedure Put_Include_Project
- (Included_Project_Path : Name_Id;
- Included_Project : Project_Node_Id;
- Including_Project_Name : String)
- is
- begin
- -- If path is null, there is nothing to do.
- -- This happens when there is no project being extended.
-
- if Included_Project_Path /= No_Name then
- Get_Name_String (Included_Project_Path);
-
- declare
- Included_Project_Name : constant String :=
- Get_Name_String (Name_Of (Included_Project));
- Included_Directory_Path : constant String :=
- Dir_Name (Name_Buffer (1 .. Name_Len));
- Last : Natural := Included_Directory_Path'Last;
-
- begin
- -- Remove possible directory separator at end of the directory
-
- if Last >= Included_Directory_Path'First
- and then (Included_Directory_Path (Last) = Directory_Separator
- or else
- Included_Directory_Path (Last) = '/')
- then
- Last := Last - 1;
- end if;
-
- Put ("BASE_DIR=");
-
- -- If it is a relative path, precede the directory with
- -- $(<PROJECT>.base_dir)/
-
- if not Is_Absolute_Path (Included_Directory_Path) then
- Put ("$(");
- Put (Including_Project_Name);
- Put (".base_dir)/");
- end if;
-
- Put (Included_Directory_Path
- (Included_Directory_Path'First .. Last));
- New_Line;
-
- -- Include the Makefile
-
- Put ("include $(BASE_DIR)");
- Put_Directory_Separator;
- Put ("Makefile.");
- Put (To_Lower (Included_Project_Name));
- New_Line;
-
- New_Line;
- end;
- end if;
- end Put_Include_Project;
-
- --------------
- -- Put_Line --
- --------------
-
- procedure Put_Line (S : String) is
- begin
- IO.Put (S);
- IO.New_Line;
- end Put_Line;
-
- ----------------
- -- Put_L_Name --
- ----------------
-
- procedure Put_L_Name (N : Name_Id) is
- begin
- Put (To_Lower (Get_Name_String (N)));
- end Put_L_Name;
-
- ----------------
- -- Put_M_Name --
- ----------------
-
- procedure Put_M_Name (N : Name_Id) is
- Name : String := Get_Name_String (N);
-
- begin
- To_Mixed (Name);
- Put (Name);
- end Put_M_Name;
-
- ----------------
- -- Put_U_Name --
- ----------------
-
- procedure Put_U_Name (N : Name_Id) is
- begin
- Put (To_Upper (Get_Name_String (N)));
- end Put_U_Name;
-
- ------------------
- -- Put_Variable --
- ------------------
-
- procedure Put_Variable
- (Project : Project_Node_Id;
- Pkg : Name_Id;
- Name : Name_Id)
- is
- begin
- Put_U_Name (Name_Of (Project));
-
- if Pkg /= No_Name then
- Put (".");
- Put_L_Name (Pkg);
- end if;
-
- Put (".");
- Put_U_Name (Name);
- end Put_Variable;
-
- -----------------------
- -- Recursive_Process --
- -----------------------
-
- procedure Recursive_Process (Project : Project_Node_Id) is
- With_Clause : Project_Node_Id;
- Last_Case : Natural := Last_Case_Construction;
- There_Are_Cases : Boolean := False;
- May_Be_C_Sources : Boolean := False;
- May_Be_Cxx_Sources : Boolean := False;
- Post_Processing : Boolean := False;
- Src_Files_Init : IO.Position;
- Src_List_File_Init : IO.Position;
- begin
- -- Nothing to do if Project is nil.
-
- if Project /= Empty_Node then
- declare
- Declaration_Node : constant Project_Node_Id :=
- Project_Declaration_Of (Project);
- -- Used to get the project being extended, if any, and the
- -- declarative items of the project to be processed.
-
- Name : constant Name_Id := Name_Of (Project);
- -- Name of the project being processed
-
- Directory : constant Name_Id := Directory_Of (Project);
- -- Directory of the project being processed. Used as default
- -- for the object directory and the source directories.
-
- Lname : constant String := To_Lower (Get_Name_String (Name));
- -- <project>: name of the project in lower case
-
- Uname : constant String := To_Upper (Lname);
- -- <PROJECT>: name of the project in upper case
-
- begin
- -- Nothing to do if project file has already been processed
-
- if Processed_Projects.Get (Name) = Empty_Node then
-
- -- Put project name in table Processed_Projects to avoid
- -- processing the project several times.
-
- Processed_Projects.Set (Name, Project);
-
- -- Process all the projects imported, if any
-
- if Process_All_Project_Files then
- With_Clause := First_With_Clause_Of (Project);
-
- while With_Clause /= Empty_Node loop
- Recursive_Process (Project_Node_Of (With_Clause));
- With_Clause := Next_With_Clause_Of (With_Clause);
- end loop;
-
- -- Process the project being extended, if any.
- -- If there is no project being extended,
- -- Process_Declarative_Items will be called with Empty_Node
- -- and nothing will happen.
-
- Recursive_Process (Extended_Project_Of (Declaration_Node));
- end if;
-
- Source_Files_Declaration := False;
- Source_List_File_Declaration := False;
-
- -- Build in Name_Buffer the path name of the Makefile
-
- -- Start with the directory of the project file
-
- Get_Name_String (Directory);
-
- -- Add a directory separator, if needed
-
- if Name_Buffer (Name_Len) /= Directory_Separator then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Directory_Separator;
- end if;
-
- -- Add the filename of the Makefile: "Makefile.<project>"
-
- Name_Buffer (Name_Len + 1 .. Name_Len + 9) := "Makefile.";
- Name_Len := Name_Len + 9;
-
- Name_Buffer (Name_Len + 1 .. Name_Len + Lname'Length) :=
- Lname;
- Name_Len := Name_Len + Lname'Length;
-
- IO.Create (Name_Buffer (1 .. Name_Len));
-
- -- Display the Makefile being created, but only if not in
- -- quiet output.
-
- if not Opt.Quiet_Output then
- Write_Str ("creating """);
- Write_Str (IO.Name_Of_File);
- Write_Line ("""");
- end if;
-
- -- And create the Makefile
-
- New_Line;
-
- -- Outut a comment with the path name of the Makefile
- Put ("# ");
- Put_Line (IO.Name_Of_File);
-
- New_Line;
-
- -- The Makefile is a big ifeq to avoid multiple inclusion
- -- ifeq ($(<PROJECT>.project),)
- -- <PROJECT>.project:=True
- -- ...
- -- endif
-
- Put ("ifeq ($(");
- Put (Uname);
- Put (".project),)");
- New_Line;
-
- Put (Uname);
- Put (".project=True");
- New_Line;
-
- New_Line;
-
- -- If it is the main Makefile (BASE_DIR is empty)
-
- Put_Line ("ifeq ($(BASE_DIR),)");
-
- -- Set <PROJECT>.root to True
-
- Put (" ");
- Put (Uname);
- Put (".root=True");
- New_Line;
-
- Put (" ");
- Put (Uname);
- Put (".base_dir:=$(shell gprcmd pwd)");
- New_Line;
-
- -- Include some utility functions and saved all reserved
- -- env. vars. by including Makefile.prolog.
-
- New_Line;
-
- -- First, if MAKE_ROOT is not defined, try to get GNAT prefix
-
- Put (" ifeq ($(");
- Put (MAKE_ROOT);
- Put ("),)");
- New_Line;
-
- Put (" MAKE_ROOT=$(shell gprcmd prefix)");
- New_Line;
-
- Put (" endif");
- New_Line;
-
- New_Line;
-
- -- If MAKE_ROOT is still not defined, then fail
-
- Put (" ifeq ($(");
- Put (MAKE_ROOT);
- Put ("),)");
- New_Line;
-
- Put (" $(error ");
- Put (MAKE_ROOT);
- Put (" variable is undefined, ");
- Put ("Makefile.prolog cannot be loaded)");
- New_Line;
-
- Put_Line (" else");
-
- Put (" include $(");
- Put (MAKE_ROOT);
- Put (")");
- Put_Directory_Separator;
- Put ("share");
- Put_Directory_Separator;
- Put ("gnat");
- Put_Directory_Separator;
- Put ("Makefile.prolog");
- New_Line;
-
- Put_Line (" endif");
-
- -- Initialize some defaults
-
- Put (" OBJ_EXT:=");
- Put (Get_Object_Suffix.all);
- New_Line;
-
- Put_Line ("else");
-
- -- When not the main Makefile, set <PROJECT>.root to False
-
- Put (" ");
- Put (Uname);
- Put (".root=False");
- New_Line;
-
- Put (" ");
- Put (Uname);
- Put (".base_dir:=$(BASE_DIR)");
- New_Line;
-
- Put_Line ("endif");
- New_Line;
-
- -- For each imported project, if any, set BASE_DIR to the
- -- directory of the imported project, and add an include
- -- directive for the Makefile of the imported project.
-
- With_Clause := First_With_Clause_Of (Project);
-
- while With_Clause /= Empty_Node loop
- Put_Include_Project
- (String_Value_Of (With_Clause),
- Project_Node_Of (With_Clause),
- Uname);
- With_Clause := Next_With_Clause_Of (With_Clause);
- end loop;
-
- -- Do the same if there is a project being extended.
- -- If there is no project being extended, Put_Include_Project
- -- will return immediately.
-
- Put_Include_Project
- (Extended_Project_Path_Of (Project),
- Extended_Project_Of (Declaration_Node),
- Uname);
-
- -- Set defaults to some variables
-
- -- CFLAGS and CXXFLAGS are set by default to nothing.
- -- Their initial values have been saved, If they are not set
- -- by this project file, then they will be reset to their
- -- initial values. This is to avoid "inheritance" of these
- -- flags from an imported project file.
-
- Put_Line ("CFLAGS:=");
- Put_Line ("CXXFLAGS:=");
-
- IO.Mark (Src_Files_Init);
- Put_Line ("src_files.specified:=FALSE");
-
- IO.Mark (Src_List_File_Init);
- Put_Line ("src_list_file.specified:=FALSE");
-
- -- Default language is Ada, but variable LANGUAGES may have
- -- been changed by an imported Makefile. So, we set it
- -- to "ada"; if attribute Languages is defined in the project
- -- file, it will be redefined.
-
- Put_Line ("LANGUAGES:=ada");
-
- -- <PROJECT>.src_dirs is set by default to the project
- -- directory.
-
- Put (Uname);
- Put (".src_dirs:=$(");
- Put (Uname);
- Put (".base_dir)");
- New_Line;
-
- -- <PROJECT>.obj_dir is set by default to the project
- -- directory.
-
- Put (Uname);
- Put (".obj_dir:=$(");
- Put (Uname);
- Put (".base_dir)");
- New_Line;
-
- -- PROJECT_FILE:=<project>
-
- Put ("PROJECT_FILE:=");
- Put (Lname);
- New_Line;
-
- -- Output a comment indicating the name of the project being
- -- processed.
-
- Put ("# project ");
- Put_M_Name (Name);
- New_Line;
-
- -- Process the external references of this project file
-
- Process_Externals (Project);
-
- New_Line;
-
- -- Reset the compiler switches, the suffixes and the languages
-
- Switches.Init;
- Reset_Suffixes_And_Languages;
-
- -- Record the current value of Last_Case_Construction to
- -- detect if there are case constructions in this project file.
-
- Last_Case := Last_Case_Construction;
-
- -- Process the declarative items of this project file
-
- Process_Declarative_Items
- (Project => Project,
- Pkg => No_Name,
- In_Case => False,
- Item => First_Declarative_Item_Of (Declaration_Node));
-
- -- Set There_Are_Case to True if there are case constructions
- -- in this project file.
-
- There_Are_Cases := Last_Case /= Last_Case_Construction;
-
- -- If the suffixes and the languages have not been specified,
- -- give them the default values.
-
- if C_Suffix_Static and then C_Suffix_Last = 0 then
- C_Suffix_Last := 2;
- C_Suffix (1 .. 2) := ".c";
- end if;
-
- if Cxx_Suffix_Static and then Cxx_Suffix_Last = 0 then
- Cxx_Suffix_Last := 3;
- Cxx_Suffix (1 .. 3) := ".cc";
- end if;
-
- if Ada_Body_Suffix_Static and then Ada_Body_Suffix_Last = 0 then
- Ada_Body_Suffix_Last := 4;
- Ada_Body_Suffix (1 .. 4) := ".adb";
- end if;
-
- if Ada_Spec_Suffix_Static and then Ada_Spec_Suffix_Last = 0 then
- Ada_Spec_Suffix_Last := 4;
- Ada_Spec_Suffix (1 .. 4) := ".ads";
- end if;
-
- if Languages_Static and then Languages_Last = 0 then
- Languages_Last := 5;
- Languages (1 .. 5) := " ada ";
- end if;
-
- -- There may be C sources if the languages are not known
- -- statically or if the languages include "C".
-
- May_Be_C_Sources := (not Languages_Static)
- or else Index
- (Source => Languages (1 .. Languages_Last),
- Pattern => " c ") /= 0;
-
- -- There may be C++ sources if the languages are not known
- -- statically or if the languages include "C++".
-
- May_Be_Cxx_Sources := (not Languages_Static)
- or else Index
- (Source => Languages (1 .. Languages_Last),
- Pattern => " c++ ") /= 0;
-
- New_Line;
-
- -- If there are attribute Switches specified in package
- -- Compiler of this project, post-process them.
-
- if Switches.Last >= Switches.First then
-
- -- Output a comment indicating this post-processing
-
- for Index in Switches.First .. Switches.Last loop
- Get_Name_String (Switches.Table (Index));
-
- declare
- File : constant String :=
- Name_Buffer (1 .. Name_Len);
- Source_Kind : Source_Kind_Type := Unknown;
-
- begin
- -- First, attempt to determine the language
-
- if Ada_Body_Suffix_Static then
- if File'Length > Ada_Body_Suffix_Last
- and then
- File (File'Last - Ada_Body_Suffix_Last + 1 ..
- File'Last) =
- Ada_Body_Suffix
- (1 .. Ada_Body_Suffix_Last)
- then
- Source_Kind := Ada_Body;
- end if;
- end if;
-
- if Source_Kind = Unknown
- and then Ada_Spec_Suffix_Static
- then
- if File'Length > Ada_Spec_Suffix_Last
- and then
- File (File'Last - Ada_Spec_Suffix_Last + 1 ..
- File'Last) =
- Ada_Spec_Suffix
- (1 .. Ada_Spec_Suffix_Last)
- then
- Source_Kind := Ada_Spec;
- end if;
- end if;
-
- if Source_Kind = Unknown
- and then C_Suffix_Static
- then
- if File'Length > C_Suffix_Last
- and then
- File (File'Last - C_Suffix_Last + 1
- .. File'Last) =
- C_Suffix (1 .. C_Suffix_Last)
- then
- Source_Kind := C;
- end if;
- end if;
-
- if Source_Kind = Unknown
- and then Cxx_Suffix_Static
- then
- if File'Length > Cxx_Suffix_Last
- and then
- File (File'Last - Cxx_Suffix_Last + 1
- .. File'Last) =
- Cxx_Suffix (1 .. Cxx_Suffix_Last)
- then
- Source_Kind := Cxx;
- end if;
- end if;
-
- -- If we still don't know the language, and all
- -- suffixes are static, then it cannot any of the
- -- processed languages.
-
- if Source_Kind = Unknown
- and then Ada_Body_Suffix_Static
- and then Ada_Spec_Suffix_Static
- and then C_Suffix_Static
- and then Cxx_Suffix_Static
- then
- Source_Kind := None;
- end if;
-
- -- If it can be "C" or "C++", post-process
-
- if (Source_Kind = Unknown and
- (May_Be_C_Sources or May_Be_Cxx_Sources))
- or else (May_Be_C_Sources and Source_Kind = C)
- or else (May_Be_Cxx_Sources and Source_Kind = Cxx)
- then
- if not Post_Processing then
- Post_Processing := True;
- Put_Line
- ("# post-processing of Compiler'Switches");
- end if;
-
- New_Line;
-
- -- Output a comment:
- -- # for Switches (<file>) use ...
-
- Put ("# for Switches (""");
- Put (File);
- Put (""") use ...");
- New_Line;
-
- if There_Are_Cases then
-
- -- Check that effectively there was Switches
- -- specified for this file: the attribute
- -- declaration may be in a case branch which was
- -- not followed.
-
- Put ("ifneq ($(");
- Put (Uname);
- Put (".compiler.switches.");
- Put (File);
- Put ("),)");
- New_Line;
- end if;
-
- if May_Be_C_Sources
- and then
- (Source_Kind = Unknown or else Source_Kind = C)
- then
- -- If it is definitely a C file, no need to test
-
- if Source_Kind = C then
- Put (File (1 .. File'Last - C_Suffix_Last));
- Put (Get_Object_Suffix.all);
- Put (": ");
- Put (File);
- New_Line;
-
- else
- -- May be a C file: test to know
-
- Put ("ifeq ($(filter %$(C_EXT),");
- Put (File);
- Put ("),");
- Put (File);
- Put (")");
- New_Line;
-
- -- If it is, output a rule for the object
-
- Put ("$(subst $(C_EXT),$(OBJ_EXT),");
- Put (File);
- Put ("): ");
- Put (File);
- New_Line;
- end if;
-
- Put (ASCII.HT & "@echo $(CC) -c $(");
- Put (Uname);
- Put (".compiler.switches.");
- Put (File);
- Put (") $< -o $(OBJ_DIR)/$@");
- New_Line;
-
- -- If FAKE_COMPILE is defined, do not issue
- -- the compile command.
-
- Put_Line ("ifndef FAKE_COMPILE");
-
- Put (ASCII.HT & "@$(CC) -c $(");
- Put (Uname);
- Put (".compiler.switches.");
- Put (File);
- Put (") $(C_INCLUDES) $(DEP_CFLAGS) " &
- "$< -o $(OBJ_DIR)/$@");
- New_Line;
-
- Put_Line (ASCII.HT & "@$(post-compile)");
-
- Put_Line ("endif");
-
- if Source_Kind = Unknown then
- Put_Line ("endif");
- end if;
- end if;
-
- -- Now, test if it is a C++ file
-
- if May_Be_Cxx_Sources
- and then
- (Source_Kind = Unknown
- or else
- Source_Kind = Cxx)
- then
- -- No need to test if definitely a C++ file
-
- if Source_Kind = Cxx then
- Put (File (1 .. File'Last - Cxx_Suffix_Last));
- Put (Get_Object_Suffix.all);
- Put (": ");
- Put (File);
- New_Line;
-
- else
- -- May be a C++ file: test to know
-
- Put ("ifeq ($(filter %$(CXX_EXT),");
- Put (File);
- Put ("),");
- Put (File);
- Put (")");
- New_Line;
-
- -- If it is, output a rule for the object
-
- Put ("$(subst $(CXX_EXT),$(OBJ_EXT),");
- Put (File);
- Put ("): $(");
- Put (Uname);
- Put (".absolute.");
- Put (File);
- Put (")");
- New_Line;
- end if;
-
- Put (ASCII.HT & "@echo $(CXX) -c $(");
- Put (Uname);
- Put (".compiler.switches.");
- Put (File);
- Put (") $< -o $(OBJ_DIR)/$@");
- New_Line;
-
- -- If FAKE_COMPILE is defined, do not issue
- -- the compile command
-
- Put_Line ("ifndef FAKE_COMPILE");
-
- Put (ASCII.HT & "@$(CXX) -c $(");
- Put (Uname);
- Put (".compiler.switches.");
- Put (File);
- Put (") $(C_INCLUDES) $(DEP_CFLAGS) " &
- "$< -o $(OBJ_DIR)/$@");
- New_Line;
-
- Put_Line (ASCII.HT & "@$(post-compile)");
-
- Put_Line ("endif");
-
- if Source_Kind = Unknown then
- Put_Line ("endif");
- end if;
-
- end if;
-
- if There_Are_Cases then
- Put_Line ("endif");
- end if;
-
- New_Line;
- end if;
- end;
- end loop;
-
- -- Output a comment indication end of post-processing
- -- of Switches, if we have done some post-processing
-
- if Post_Processing then
- Put_Line
- ("# end of post-processing of Compiler'Switches");
-
- New_Line;
- end if;
- end if;
-
- -- Add source dirs of this project file to variable SRC_DIRS.
- -- Put them in front, and remove duplicates.
-
- Put ("SRC_DIRS:=$(");
- Put (Uname);
- Put (".src_dirs) $(filter-out $(");
- Put (Uname);
- Put (".src_dirs),$(SRC_DIRS))");
- New_Line;
-
- -- Set OBJ_DIR to the object directory
-
- Put ("OBJ_DIR:=$(");
- Put (Uname);
- Put (".obj_dir)");
- New_Line;
-
- New_Line;
-
- if Source_Files_Declaration = True then
-
- -- It is guaranteed that Source_Files has been specified.
- -- We then suppress the two lines that initialize
- -- the variables src_files.specified and
- -- src_list_file.specified. Nothing else to do.
-
- IO.Suppress (Src_Files_Init);
- IO.Suppress (Src_List_File_Init);
-
- else
- if Source_Files_Declaration = May_Be then
-
- -- Need to test if attribute Source_Files was specified
-
- Put_Line ("# get the source files, if necessary");
- Put_Line ("ifeq ($(src_files.specified),FALSE)");
-
- else
- Put_Line ("# get the source files");
-
- -- We may suppress initialization of src_files.specified
-
- IO.Suppress (Src_Files_Init);
- end if;
-
- if Source_List_File_Declaration /= May_Be then
- IO.Suppress (Src_List_File_Init);
- end if;
-
- case Source_List_File_Declaration is
-
- -- Source_List_File was specified
-
- when True =>
- if Source_Files_Declaration = May_Be then
- Put (" ");
- end if;
-
- Put (Uname);
- Put (".src_files:= $(shell gprcmd cat " &
- "$(src.list_file))");
- New_Line;
-
- -- Source_File_List was NOT specified
-
- when False =>
- if Source_Files_Declaration = May_Be then
- Put (" ");
- end if;
-
- Put (Uname);
- Put (".src_files:= $(foreach name,$(");
- Put (Uname);
- Put (".src_dirs),$(notdir $(wildcard $(name)/*)))");
- New_Line;
-
- when May_Be =>
- if Source_Files_Declaration = May_Be then
- Put (" ");
- end if;
-
- Put_Line ("ifeq ($(src_list_file.specified),TRUE)");
-
- -- Get the source files from the file
-
- if Source_Files_Declaration = May_Be then
- Put (" ");
- end if;
-
- Put (" ");
- Put (Uname);
- Put (".src_files:= $(shell gprcmd cat " &
- "$(SRC__$LIST_FILE))");
- New_Line;
-
- if Source_Files_Declaration = May_Be then
- Put (" ");
- end if;
-
- Put_Line ("else");
-
- -- Otherwise get source from the source directories
-
- if Source_Files_Declaration = May_Be then
- Put (" ");
- end if;
-
- Put (" ");
- Put (Uname);
- Put (".src_files:= $(foreach name,$(");
- Put (Uname);
- Put (".src_dirs),$(notdir $(wildcard $(name)/*)))");
- New_Line;
-
- if Source_Files_Declaration = May_Be then
- Put (" ");
- end if;
-
- Put_Line ("endif");
- end case;
-
- if Source_Files_Declaration = May_Be then
- Put_Line ("endif");
- end if;
-
- New_Line;
- end if;
-
- if not Languages_Static then
-
- -- If Languages include "c", get the C sources
-
- Put_Line
- ("# get the C source files, if C is one of the languages");
-
- Put_Line ("ifeq ($(filter c,$(LANGUAGES)),c)");
-
- Put (" C_SRCS:=$(filter %$(C_EXT),$(");
- Put (Uname);
- Put (".src_files))");
- New_Line;
- Put_Line (" C_SRCS_DEFINED:=True");
-
- -- Otherwise set C_SRCS to empty
-
- Put_Line ("else");
- Put_Line (" C_SRCS=");
- Put_Line ("endif");
- New_Line;
-
- -- If Languages include "C++", get the C++ sources
-
- Put_Line
- ("# get the C++ source files, " &
- "if C++ is one of the languages");
-
- Put_Line ("ifeq ($(filter c++,$(LANGUAGES)),c++)");
-
- Put (" CXX_SRCS:=$(filter %$(CXX_EXT),$(");
- Put (Uname);
- Put (".src_files))");
- New_Line;
- Put_Line (" CXX_SRCS_DEFINED:=True");
-
- -- Otherwise set CXX_SRCS to empty
-
- Put_Line ("else");
- Put_Line (" CXX_SRCS=");
- Put_Line ("endif");
- New_Line;
-
- else
- if Ada.Strings.Fixed.Index
- (Languages (1 .. Languages_Last), " c ") /= 0
- then
- Put_Line ("# get the C sources");
- Put ("C_SRCS:=$(filter %$(C_EXT),$(");
- Put (Uname);
- Put (".src_files))");
- New_Line;
- Put_Line ("C_SRCS_DEFINED:=True");
-
- else
- Put_Line ("# no C sources");
-
- Put_Line ("C_SRCS=");
- end if;
-
- New_Line;
-
- if Ada.Strings.Fixed.Index
- (Languages (1 .. Languages_Last), " c++ ") /= 0
- then
- Put_Line ("# get the C++ sources");
- Put ("CXX_SRCS:=$(filter %$(CXX_EXT),$(");
- Put (Uname);
- Put (".src_files))");
- New_Line;
- Put_Line ("CXX_SRCS_DEFINED:=True");
-
- else
- Put_Line ("# no C++ sources");
-
- Put_Line ("CXX_SRCS=");
- end if;
-
- New_Line;
- end if;
-
- declare
- C_Present : constant Boolean :=
- (not Languages_Static) or else
- Ada.Strings.Fixed.Index
- (Languages (1 .. Languages_Last), " c ")
- /= 0;
-
- Cxx_Present : constant Boolean :=
- (not Languages_Static) or else
- Ada.Strings.Fixed.Index
- (Languages (1 .. Languages_Last), " c++ ")
- /= 0;
-
- begin
- if C_Present or Cxx_Present then
-
- -- If there are C or C++ sources,
- -- add a library name to variable LIBS.
-
- Put ("# if there are ");
-
- if C_Present then
- if Cxx_Present then
- Put ("C or C++");
-
- else
- Put ("C");
- end if;
-
- else
- Put ("C++");
- end if;
-
- Put (" sources, add the library");
- New_Line;
-
- Put ("ifneq ($(strip");
-
- if C_Present then
- Put (" $(C_SRCS)");
- end if;
-
- if Cxx_Present then
- Put (" $(CXX_SRCS)");
- end if;
-
- Put ("),)");
- New_Line;
-
- Put (" LIBS:=$(");
- Put (Uname);
- Put (".obj_dir)/lib");
- Put (Lname);
- Put ("$(AR_EXT) $(LIBS)");
- New_Line;
-
- Put_Line ("endif");
-
- New_Line;
-
- end if;
- end;
-
- -- If CFLAGS/CXXFLAGS have not been set, set them back to
- -- their initial values.
-
- Put_Line ("ifeq ($(CFLAGS),)");
- Put_Line (" CFLAGS:=$(CFLAGS.saved)");
- Put_Line ("endif");
- New_Line;
-
- Put_Line ("ifeq ($(CXXFLAGS),)");
- Put_Line (" CXXFLAGS:=$(CXXFLAGS.saved)");
- Put_Line ("endif");
- New_Line;
-
- -- If this is the main Makefile, include Makefile.Generic
-
- Put ("ifeq ($(");
- Put (Uname);
- Put_Line (".root),True)");
-
- -- Include Makefile.generic
-
- Put (" include $(");
- Put (MAKE_ROOT);
- Put (")");
- Put_Directory_Separator;
- Put ("share");
- Put_Directory_Separator;
- Put ("gnat");
- Put_Directory_Separator;
- Put ("Makefile.generic");
- New_Line;
-
- -- If it is not the main Makefile, add the project to
- -- variable DEPS_PROJECTS.
-
- Put_Line ("else");
-
- Put (" DEPS_PROJECTS:=$(strip $(DEPS_PROJECTS) $(");
- Put (Uname);
- Put (".base_dir)/");
- Put (Lname);
- Put (")");
- New_Line;
-
- Put_Line ("endif");
- New_Line;
-
- Put_Line ("endif");
- New_Line;
-
- -- Close the Makefile, so that another Makefile can be created
- -- with the same File_Type variable.
-
- IO.Close;
- end if;
- end;
- end if;
- end Recursive_Process;
-
- ----------------------------------
- -- Reset_Suffixes_And_Languages --
- ----------------------------------
-
- procedure Reset_Suffixes_And_Languages is
- begin
- -- Last = 0 indicates that this is the default, which is static,
- -- of course.
-
- C_Suffix_Last := 0;
- C_Suffix_Static := True;
- Cxx_Suffix_Last := 0;
- Cxx_Suffix_Static := True;
- Ada_Body_Suffix_Last := 0;
- Ada_Body_Suffix_Static := True;
- Ada_Spec_Suffix_Last := 0;
- Ada_Spec_Suffix_Static := True;
- Languages_Last := 0;
- Languages_Static := True;
- end Reset_Suffixes_And_Languages;
-
- --------------------
- -- Source_Kind_Of --
- --------------------
-
- function Source_Kind_Of (File_Name : Name_Id) return Source_Kind_Type is
- Source_C_Suffix : constant String :=
- Suffix_Of (C_Suffix_Static, C_Suffix, C_Suffix_Last, ".c");
-
- Source_Cxx_Suffix : constant String :=
- Suffix_Of (Cxx_Suffix_Static, Cxx_Suffix, Cxx_Suffix_Last, ".cc");
-
- Body_Ada_Suffix : constant String :=
- Suffix_Of
- (Ada_Body_Suffix_Static,
- Ada_Body_Suffix,
- Ada_Body_Suffix_Last,
- ".adb");
-
- Spec_Ada_Suffix : constant String :=
- Suffix_Of
- (Ada_Spec_Suffix_Static,
- Ada_Spec_Suffix,
- Ada_Spec_Suffix_Last,
- ".ads");
-
- begin
- -- Get the name of the file
-
- Get_Name_String (File_Name);
-
- -- If the C suffix is static, check if it is a C file
-
- if Source_C_Suffix /= ""
- and then Name_Len > Source_C_Suffix'Length
- and then Name_Buffer (Name_Len - Source_C_Suffix'Length + 1
- .. Name_Len) = Source_C_Suffix
- then
- return C;
-
- -- If the C++ suffix is static, check if it is a C++ file
-
- elsif Source_Cxx_Suffix /= ""
- and then Name_Len > Source_Cxx_Suffix'Length
- and then Name_Buffer (Name_Len - Source_Cxx_Suffix'Length + 1
- .. Name_Len) = Source_Cxx_Suffix
- then
- return Cxx;
-
- -- If the Ada body suffix is static, check if it is an Ada body
-
- elsif Body_Ada_Suffix /= ""
- and then Name_Len > Body_Ada_Suffix'Length
- and then Name_Buffer (Name_Len - Body_Ada_Suffix'Length + 1
- .. Name_Len) = Body_Ada_Suffix
- then
- return Ada_Body;
-
- -- If the Ada spec suffix is static, check if it is an Ada spec
-
- elsif Spec_Ada_Suffix /= ""
- and then Name_Len > Spec_Ada_Suffix'Length
- and then Name_Buffer (Name_Len - Spec_Ada_Suffix'Length + 1
- .. Name_Len) = Spec_Ada_Suffix
- then
- return Ada_Body;
-
- -- If the C or C++ suffix is not static, then return Unknown
-
- elsif Source_C_Suffix = "" or else Source_Cxx_Suffix = "" then
- return Unknown;
-
- -- Otherwise return None
-
- else
- return None;
- end if;
- end Source_Kind_Of;
-
- ------------------------
- -- Special_Put_U_Name --
- ------------------------
-
- procedure Special_Put_U_Name (S : Name_Id) is
- begin
- Get_Name_String (S);
- To_Upper (Name_Buffer (1 .. Name_Len));
-
- -- If string is "C++", change it to "CXX"
-
- if Name_Buffer (1 .. Name_Len) = "C++" then
- Put ("CXX");
- else
- Put (Name_Buffer (1 .. Name_Len));
- end if;
- end Special_Put_U_Name;
-
- ---------------
- -- Suffix_Of --
- ---------------
-
- function Suffix_Of
- (Static : Boolean;
- Value : String_Access;
- Last : Natural;
- Default : String) return String
- is
- begin
- if Static then
-
- -- If the suffix is static, Last = 0 indicates that it is the default
- -- suffix: return the default.
-
- if Last = 0 then
- return Default;
-
- -- Otherwise, return the current suffix
-
- else
- return Value (1 .. Last);
- end if;
-
- -- If the suffix is not static, return ""
-
- else
- return "";
- end if;
- end Suffix_Of;
-
- -----------
- -- Usage --
- -----------
-
- procedure Usage is
- begin
- if not Usage_Displayed then
- Usage_Displayed := True;
- Display_Copyright;
- Write_Line ("Usage: gpr2make switches project-file");
- Write_Eol;
- Write_Line (" -h Display this usage");
- Write_Line (" -q Quiet output");
- Write_Line (" -v Verbose mode");
- Write_Line (" -R not Recursive: only one project file");
- Write_Eol;
- end if;
- end Usage;
-end Bld;
diff --git a/gcc/ada/bld.ads b/gcc/ada/bld.ads
deleted file mode 100644
index 1389dc582c8..00000000000
--- a/gcc/ada/bld.ads
+++ /dev/null
@@ -1,38 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- B L D --
--- --
--- S p e c --
--- --
--- 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- 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 build Makefiles
--- for multi-language GNAT project files, so that building a complete
--- multi-language system can be done easily, using GNU make.
-
-package Bld is
-
- procedure Gpr2make;
- -- Parse a project file and all the other project files it depends on
- -- into a project tree; then from the project tree, produce one Makefile
- -- for each project file in the project tree.
-
-end Bld;
diff --git a/gcc/ada/g-soccon-darwin.ads b/gcc/ada/g-soccon-darwin.ads
new file mode 100644
index 00000000000..7010c8b4a2c
--- /dev/null
+++ b/gcc/ada/g-soccon-darwin.ads
@@ -0,0 +1,163 @@
+------------------------------------------------------------------------------
+-- --
+-- 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-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, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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-darwin7.4.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 := 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_SNDBUF : constant := 4097; -- Set/get send buffer size
+ SO_RCVBUF : constant := 4098; -- Set/get recv buffer size
+ 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_ERROR : constant := 4103; -- Get/clear error status
+ SO_BROADCAST : constant := 32; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback
+
+end GNAT.Sockets.Constants;
diff --git a/gcc/ada/gpr2make.adb b/gcc/ada/gpr2make.adb
deleted file mode 100644
index eb93f345fc3..00000000000
--- a/gcc/ada/gpr2make.adb
+++ /dev/null
@@ -1,34 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G P R 2 M A K E --
--- --
--- B o d y --
--- --
--- 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Bld;
-
-procedure Gpr2make is
-begin
- -- The real work is done in package Bld.
-
- Bld.Gpr2make;
-end Gpr2make;
diff --git a/gcc/ada/gpr2make.ads b/gcc/ada/gpr2make.ads
deleted file mode 100644
index 0f05e9046d7..00000000000
--- a/gcc/ada/gpr2make.ads
+++ /dev/null
@@ -1,30 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G P R 2 M A K E --
--- --
--- S p e c --
--- --
--- 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-procedure Gpr2make;
--- The driver for the gpr2make tool. This utility is a Makefile generator
--- to help building multi-language applications, using multi-language
--- GNAT project files.
diff --git a/gcc/ada/gprcmd.adb b/gcc/ada/gprcmd.adb
deleted file mode 100644
index 143b62b1dea..00000000000
--- a/gcc/ada/gprcmd.adb
+++ /dev/null
@@ -1,612 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G P R C M D --
--- --
--- B o d y --
--- --
--- Copyright (C) 2002-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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- A utility used by Makefile.generic to handle multi-language builds.
--- gprcmd provides a set of commands so that the makefiles do not need
--- to depend on unix utilities not available on all targets.
-
--- The list of commands recognized by gprcmd are:
-
--- pwd display current directory
--- to_lower display next argument in lower case
--- to_absolute convert pathnames to absolute directories when needed
--- cat dump contents of a given file
--- extend handle recursive directories ("/**" notation)
--- deps post process dependency makefiles
--- stamp copy file time stamp from file1 to file2
--- prefix get the prefix of the GNAT installation
--- path convert a list of directories to a path list, inserting a
--- path separator after each directory, including the last one
--- ignore do nothing
-
-with Gnatvsn;
-with Osint; use Osint;
-with Namet; use Namet;
-
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Text_IO; use Ada.Text_IO;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.Regpat; use GNAT.Regpat;
-
-procedure Gprcmd is
-
- -- ??? comments are thin throughout this unit
-
- Gprdebug : constant String := To_Lower (Getenv ("GPRDEBUG").all);
- Debug : constant Boolean := Gprdebug = "true";
- -- When Debug is True, gprcmd displays its arguments to Standard_Error.
- -- This is to help to debug.
-
- procedure Cat (File : String);
- -- Print the contents of file on standard output.
- -- If the file cannot be read, exit the process with an error code.
-
- procedure Check_Args (Condition : Boolean);
- -- If Condition is false, print command invoked, then the usage,
- -- and exit the process.
-
- procedure Deps (Objext : String; File : String; GCC : Boolean);
- -- Process $(CC) dependency file. If GCC is True, add a rule so that make
- -- will not complain when a file is removed/added. If GCC is False, add a
- -- rule to recompute the dependency file when needed
-
- procedure Extend (Dir : String);
- -- If Dir ends with /**, Put all subdirs recursively on standard output,
- -- otherwise put Dir.
-
- procedure Usage;
- -- Display the command line options and exit the process.
-
- procedure Copy_Time_Stamp (From, To : String);
- -- Copy file time stamp from file From to file To.
-
- procedure Display_Command;
- -- Display the invoked command to Standard_Error
-
- ---------
- -- Cat --
- ---------
-
- procedure Cat (File : String) is
- FD : File_Descriptor;
- Buffer : String_Access;
- Length : Integer;
-
- begin
- FD := Open_Read (File, Fmode => Binary);
-
- if FD = Invalid_FD then
- OS_Exit (2);
- end if;
-
- Length := Integer (File_Length (FD));
- Buffer := new String (1 .. Length);
- Length := Read (FD, Buffer.all'Address, Length);
- Close (FD);
- Put (Buffer.all);
- Free (Buffer);
- end Cat;
-
- ----------------
- -- Check_Args --
- ----------------
-
- procedure Check_Args (Condition : Boolean) is
- begin
- if not Condition then
- Put_Line
- (Standard_Error,
- "bad call to gprcmd with" & Argument_Count'Img & " arguments.");
-
- for J in 0 .. Argument_Count loop
- Put (Standard_Error, Argument (J) & " ");
- end loop;
-
- New_Line (Standard_Error);
-
- Usage;
- end if;
- end Check_Args;
-
- ---------------------
- -- Copy_Time_Stamp --
- ---------------------
-
- procedure Copy_Time_Stamp (From, To : String) is
- function Copy_Attributes
- (From, To : String;
- Mode : Integer) return Integer;
- pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
- -- Mode = 0 - copy only time stamps.
- -- Mode = 1 - copy time stamps and read/write/execute attributes
-
- FD : File_Descriptor;
-
- begin
- if not Is_Regular_File (From) then
- return;
- end if;
-
- FD := Create_File (To, Fmode => Binary);
-
- if FD = Invalid_FD then
- OS_Exit (2);
- end if;
-
- Close (FD);
-
- if Copy_Attributes (From & ASCII.NUL, To & ASCII.NUL, 0) /= 0 then
- OS_Exit (2);
- end if;
- end Copy_Time_Stamp;
-
- ----------
- -- Deps --
- ----------
-
- procedure Deps (Objext : String; File : String; GCC : Boolean) is
- Colon : constant String := ':' & ASCII.LF;
- NL : constant String := (1 => ASCII.LF);
- Base : constant String := ' ' & Base_Name (File) & ": ";
- FD : File_Descriptor;
- Buffer : String_Access;
- Length : Integer;
- Obj_Regexp : constant Pattern_Matcher :=
- Compile ("^.*\" & Objext & ": ");
- Matched : Match_Array (0 .. 0);
- Start : Natural;
- First : Natural;
- Last : Natural;
-
- begin
- FD := Open_Read_Write (File, Fmode => Binary);
-
- if FD = Invalid_FD then
- return;
- end if;
-
- Length := Integer (File_Length (FD));
- Buffer := new String (1 .. Length);
- Length := Read (FD, Buffer.all'Address, Length);
-
- if GCC then
- Lseek (FD, 0, Seek_End);
- else
- Close (FD);
- FD := Create_File (File, Fmode => Binary);
- end if;
-
- Start := Buffer'First;
-
- while Start <= Buffer'Last loop
-
- -- Parse Buffer line by line
-
- while Start < Buffer'Last
- and then (Buffer (Start) = ASCII.CR
- or else Buffer (Start) = ASCII.LF)
- loop
- Start := Start + 1;
- end loop;
-
- Last := Start;
-
- while Last < Buffer'Last
- and then Buffer (Last + 1) /= ASCII.CR
- and then Buffer (Last + 1) /= ASCII.LF
- loop
- Last := Last + 1;
- end loop;
-
- Match (Obj_Regexp, Buffer (Start .. Last), Matched);
-
- if GCC then
- if Matched (0) = No_Match then
- First := Start;
- else
- First := Matched (0).Last + 1;
- end if;
-
- Length := Write (FD, Buffer (First)'Address, Last - First + 1);
-
- if Start = Last or else Buffer (Last) = '\' then
- Length := Write (FD, NL (1)'Address, NL'Length);
- else
- Length := Write (FD, Colon (1)'Address, Colon'Length);
- end if;
-
- else
- if Matched (0) = No_Match then
- First := Start;
- else
- Length :=
- Write (FD, Buffer (Start)'Address,
- Matched (0).Last - Start - 1);
- Length := Write (FD, Base (Base'First)'Address, Base'Length);
- First := Matched (0).Last + 1;
- end if;
-
- Length := Write (FD, Buffer (First)'Address, Last - First + 1);
- Length := Write (FD, NL (1)'Address, NL'Length);
- end if;
-
- Start := Last + 1;
- end loop;
-
- Close (FD);
- Free (Buffer);
- end Deps;
-
- ---------------------
- -- Display_Command --
- ---------------------
-
- procedure Display_Command is
- begin
- for J in 0 .. Argument_Count loop
- Put (Standard_Error, Argument (J) & ' ');
- end loop;
-
- New_Line (Standard_Error);
- end Display_Command;
-
- ------------
- -- Extend --
- ------------
-
- procedure Extend (Dir : String) is
-
- procedure Recursive_Extend (D : String);
- -- Recursively display all subdirectories of D
-
- ----------------------
- -- Recursive_Extend --
- ----------------------
-
- procedure Recursive_Extend (D : String) is
- Iter : Dir_Type;
- Buffer : String (1 .. 8192);
- Last : Natural;
-
- begin
- Open (Iter, D);
-
- loop
- Read (Iter, Buffer, Last);
- exit when Last = 0;
-
- if Buffer (1 .. Last) /= "."
- and then Buffer (1 .. Last) /= ".."
- then
- declare
- Abs_Dir : constant String := D & "/" & Buffer (1 .. Last);
- begin
- if Is_Directory (Abs_Dir)
- and then not Is_Symbolic_Link (Abs_Dir)
- then
- Put (' ' & Abs_Dir);
- Recursive_Extend (Abs_Dir);
- end if;
- end;
- end if;
- end loop;
-
- Close (Iter);
-
- exception
- when Directory_Error =>
- null;
- end Recursive_Extend;
-
- -- Start of processing for Extend
-
- begin
- if Dir'Length < 3
- or else (Dir (Dir'Last - 2) /= '/'
- and then Dir (Dir'Last - 2) /= Directory_Separator)
- or else Dir (Dir'Last - 1 .. Dir'Last) /= "**"
- then
- Put (Dir);
- return;
- end if;
-
- declare
- D : constant String := Dir (Dir'First .. Dir'Last - 3);
- begin
- Put (D);
- Recursive_Extend (D);
- end;
- end Extend;
-
- -----------
- -- Usage --
- -----------
-
- procedure Usage is
- begin
- Put_Line (Standard_Error, "usage: gprcmd cmd [arguments]");
- Put_Line (Standard_Error, "where cmd is one of the following commands:");
- Put_Line (Standard_Error, " pwd " &
- "display current directory");
- Put_Line (Standard_Error, " to_lower " &
- "display next argument in lower case");
- Put_Line (Standard_Error, " to_absolute " &
- "convert pathnames to absolute " &
- "directories when needed");
- Put_Line (Standard_Error, " cat " &
- "dump contents of a given file");
- Put_Line (Standard_Error, " extend " &
- "handle recursive directories " &
- "(""/**"" notation)");
- Put_Line (Standard_Error, " deps " &
- "post process dependency makefiles");
- Put_Line (Standard_Error, " stamp " &
- "copy file time stamp from file1 to file2");
- Put_Line (Standard_Error, " prefix " &
- "get the prefix of the GNAT installation");
- Put_Line (Standard_Error, " path_sep " &
- "returns the path separator");
- Put_Line (Standard_Error, " linkopts " &
- "process attribute Linker'Linker_Options");
- Put_Line (Standard_Error, " ignore " &
- "do nothing");
- OS_Exit (1);
- end Usage;
-
--- Start of processing for Gprcmd
-
-begin
- if Debug then
- Display_Command;
- end if;
-
- Check_Args (Argument_Count > 0);
-
- declare
- Cmd : constant String := Argument (1);
-
- begin
- if Cmd = "-v" then
-
- -- Output on standard error, because only returned values should
- -- go to standard output.
-
- Put (Standard_Error, "GPRCMD ");
- Put_Line (Standard_Error, Gnatvsn.Gnat_Version_String);
- Put_Line (Standard_Error,
- "Copyright 2002-2004, Free Software Fundation, Inc.");
- Usage;
-
- elsif Cmd = "pwd" then
- declare
- CD : constant String := Get_Current_Dir;
- begin
- Put (Format_Pathname (CD (CD'First .. CD'Last - 1), UNIX));
- end;
-
- elsif Cmd = "cat" then
- Check_Args (Argument_Count = 2);
- Cat (Argument (2));
-
- elsif Cmd = "to_lower" then
- Check_Args (Argument_Count >= 2);
-
- for J in 2 .. Argument_Count loop
- Put (To_Lower (Argument (J)));
-
- if J < Argument_Count then
- Put (' ');
- end if;
- end loop;
-
- elsif Cmd = "to_absolute" then
- Check_Args (Argument_Count > 2);
-
- declare
- Dir : constant String := Argument (2);
-
- begin
- for J in 3 .. Argument_Count loop
- if Is_Absolute_Path (Argument (J)) then
- Put (Format_Pathname (Argument (J), UNIX));
- else
- Put (Format_Pathname
- (Normalize_Pathname
- (Format_Pathname (Argument (J)),
- Format_Pathname (Dir)),
- UNIX));
- end if;
-
- if J < Argument_Count then
- Put (' ');
- end if;
- end loop;
- end;
-
- elsif Cmd = "extend" then
- Check_Args (Argument_Count >= 2);
-
- declare
- Dir : constant String := Argument (2);
-
- begin
- -- Loop to remove quotes that may have been added around arguments
-
- for J in 3 .. Argument_Count loop
- declare
- Arg : constant String := Argument (J);
- First : Natural := Arg'First;
- Last : Natural := Arg'Last;
-
- begin
- if Arg (First) = '"' and then Arg (Last) = '"' then
- First := First + 1;
- Last := Last - 1;
- end if;
-
- if Is_Absolute_Path (Arg (First .. Last)) then
- Extend (Format_Pathname (Arg (First .. Last), UNIX));
- else
- Extend
- (Format_Pathname
- (Normalize_Pathname
- (Format_Pathname (Arg (First .. Last)),
- Format_Pathname (Dir)),
- UNIX));
- end if;
-
- if J < Argument_Count then
- Put (' ');
- end if;
- end;
- end loop;
- end;
-
- elsif Cmd = "deps" then
- Check_Args (Argument_Count in 3 .. 4);
- Deps (Argument (2), Argument (3), GCC => Argument_Count = 4);
-
- elsif Cmd = "stamp" then
- Check_Args (Argument_Count = 3);
- Copy_Time_Stamp (Argument (2), Argument (3));
-
- elsif Cmd = "prefix" then
-
- -- Find the GNAT prefix. gprcmd is found in <prefix>/bin.
- -- So we find the full path of gprcmd, verify that it is in a
- -- subdirectory "bin", and return the <prefix> if it is the case.
- -- Otherwise, nothing is returned.
-
- Find_Program_Name;
-
- declare
- Path : constant String_Access :=
- Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
- Index : Natural;
-
- begin
- if Path /= null then
- Index := Path'Last;
-
- while Index >= Path'First + 4 loop
- exit when Path (Index) = Directory_Separator;
- Index := Index - 1;
- end loop;
-
- if Index > Path'First + 5
- and then Path (Index - 3 .. Index - 1) = "bin"
- and then Path (Index - 4) = Directory_Separator
- then
- -- We have found the <prefix>, return it
-
- Put (Path (Path'First .. Index - 5));
- end if;
- end if;
- end;
-
- -- For "path" just add path separator after each directory argument
-
- elsif Cmd = "path_sep" then
- Put (Path_Separator);
-
- -- Check the linker options for relative paths. Insert the project
- -- base dir before relative paths.
-
- elsif Cmd = "linkopts" then
- Check_Args (Argument_Count >= 2);
-
- -- First argument is the base directory of the project file
-
- declare
- Base_Dir : constant String := Argument (2) & '/';
- begin
- -- process the remainder of the arguments
-
- for J in 3 .. Argument_Count loop
- declare
- Arg : constant String := Argument (J);
- begin
- -- If it is a switch other than a -L switch, just send back
- -- the argument.
-
- if Arg (Arg'First) = '-' and then
- (Arg'Length <= 2 or else Arg (Arg'First + 1) /= 'L')
- then
- Put (Arg);
-
- else
- -- If it is a file, check if its path is relative, and
- -- if it is relative, add <project base dir>/ in front.
- -- Otherwise just send back the argument.
-
- if Arg'Length <= 2
- or else Arg (Arg'First .. Arg'First + 1) /= "-L"
- then
- if not Is_Absolute_Path (Arg) then
- Put (Base_Dir);
- end if;
-
- Put (Arg);
-
- -- For -L switches, check if the path is relative and
- -- proceed similarly.
-
- else
- Put ("-L");
-
- if
- not Is_Absolute_Path (Arg (Arg'First + 2 .. Arg'Last))
- then
- Put (Base_Dir);
- end if;
-
- Put (Arg (Arg'First + 2 .. Arg'Last));
- end if;
- end if;
- end;
-
- -- Insert a space between each processed argument
-
- if J /= Argument_Count then
- Put (' ');
- end if;
- end loop;
- end;
-
- -- For "ignore" do nothing
-
- elsif Cmd = "ignore" then
- null;
-
- -- Unknown command
-
- else
- Check_Args (False);
- end if;
- end;
-end Gprcmd;
View Lorry Controller Status