+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N I T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2003-2004 Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 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. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Level A cert version of this package for AE653
-
-with Interfaces.C;
--- Used for int and other types
-
-with Ada.Exceptions;
--- Used for Raise_Exception
-
-package body System.Init is
-
- use Ada.Exceptions;
- use Interfaces.C;
-
- --------------------------
- -- Signal Definitions --
- --------------------------
-
- NSIG : constant := 32;
- -- Number of signals on the target OS
-
- type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
-
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGFPE : constant := 8; -- floating point exception
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
-
- type sigset_t is new long;
-
- SIG_SETMASK : constant := 3;
- SA_ONSTACK : constant := 16#0004#;
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- type sigset_t_ptr is access all sigset_t;
-
- function pthread_sigmask
- (how : int;
- set : sigset_t_ptr;
- oset : sigset_t_ptr) return int;
- pragma Import (C, pthread_sigmask, "sigprocmask");
-
- -------------------------------
- -- Binder Generated Values --
- -------------------------------
-
- Gl_Main_Priority : Integer := -1;
- pragma Export (C, Gl_Main_Priority, "__gl_main_priority");
-
- Gl_Time_Slice_Val : Integer := -1;
- pragma Export (C, Gl_Time_Slice_Val, "__gl_time_slice_val");
-
- Gl_Wc_Encoding : Character := 'n';
- pragma Export (C, Gl_Wc_Encoding, "__gl_wc_encoding");
-
- Gl_Locking_Policy : Character := ' ';
- pragma Export (C, Gl_Locking_Policy, "__gl_locking_policy");
-
- Gl_Queuing_Policy : Character := ' ';
- pragma Export (C, Gl_Queuing_Policy, "__gl_queuing_policy");
-
- Gl_Task_Dispatching_Policy : Character := ' ';
- pragma Export (C, Gl_Task_Dispatching_Policy,
- "__gl_task_dispatching_policy");
-
- Gl_Restrictions : Address := Null_Address;
- pragma Export (C, Gl_Restrictions, "__gl_restrictions");
-
- Gl_Interrupt_States : Address := Null_Address;
- pragma Export (C, Gl_Interrupt_States, "__gl_interrupt_states");
-
- Gl_Num_Interrupt_States : Integer := 0;
- pragma Export (C, Gl_Num_Interrupt_States, "__gl_num_interrupt_states");
-
- Gl_Unreserve_All_Interrupts : Integer := 0;
- pragma Export (C, Gl_Unreserve_All_Interrupts,
- "__gl_unreserve_all_interrupts");
-
- Gl_Exception_Tracebacks : Integer := 0;
- pragma Export (C, Gl_Exception_Tracebacks, "__gl_exception_tracebacks");
-
- Gl_Zero_Cost_Exceptions : Integer := 0;
- pragma Export (C, Gl_Zero_Cost_Exceptions, "__gl_zero_cost_exceptions");
-
- Already_Called : Boolean := False;
-
- Handler_Installed : Integer := 0;
- pragma Export (C, Handler_Installed, "__gnat_handler_installed");
- -- Indication of whether synchronous signal handlers have already been
- -- installed by a previous call to Install_Handler.
-
- ------------------------
- -- Local procedures --
- ------------------------
-
- procedure GNAT_Error_Handler (Sig : Signal);
- -- Common procedure that is executed when a SIGFPE, SIGILL,
- -- SIGSEGV, or SIGBUS is captured.
-
- ------------------------
- -- GNAT_Error_Handler --
- ------------------------
-
- procedure GNAT_Error_Handler (Sig : Signal) is
- Mask : aliased sigset_t;
-
- Result : int;
- pragma Unreferenced (Result);
-
- begin
- -- VxWorks will always mask out the signal during the signal
- -- handler and will reenable it on a longjmp. GNAT does not
- -- generate a longjmp to return from a signal handler so the
- -- signal will still be masked unless we unmask it.
-
- Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
- Result := sigdelset (Mask'Access, Sig);
- Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
-
- case Sig is
- when SIGFPE =>
- Raise_Exception (Constraint_Error'Identity, "SIGFPE");
- when SIGILL =>
- Raise_Exception (Constraint_Error'Identity, "SIGILL");
- when SIGSEGV =>
- Raise_Exception
- (Program_Error'Identity,
- "erroneous memory access");
- when SIGBUS =>
- Raise_Exception
- (Storage_Error'Identity,
- "stack overflow or SIGBUS");
- when others =>
- Raise_Exception (Program_Error'Identity, "unhandled signal");
- end case;
- end GNAT_Error_Handler;
-
- -----------------
- -- Set_Globals --
- -----------------
-
- -- This routine is called from the binder generated main program. It
- -- copies the values for global quantities computed by the binder
- -- into the following global locations. The reason that we go through
- -- this copy, rather than just define the global locations in the
- -- binder generated file, is that they are referenced from the
- -- runtime, which may be in a shared library, and the binder file is
- -- not in the shared library. Global references across library
- -- boundaries like this are not handled correctly in all systems.
-
- procedure Set_Globals
- (Main_Priority : Integer;
- Time_Slice_Value : Integer;
- WC_Encoding : Character;
- Locking_Policy : Character;
- Queuing_Policy : Character;
- Task_Dispatching_Policy : Character;
- Restrictions : System.Address;
- Interrupt_States : System.Address;
- Num_Interrupt_States : Integer;
- Unreserve_All_Interrupts : Integer;
- Exception_Tracebacks : Integer;
- Zero_Cost_Exceptions : Integer)
- is
- begin
- -- If this procedure has been already called once, check that the
- -- arguments in this call are consistent with the ones in the
- -- previous calls. Otherwise, raise a Program_Error exception.
-
- -- We do not check for consistency of the wide character encoding
- -- method. This default affects only Wide_Text_IO where no
- -- explicit coding method is given, and there is no particular
- -- reason to let this default be affected by the source
- -- representation of a library in any case.
-
- -- We do not check either for the consistency of exception tracebacks,
- -- because exception tracebacks are not normally set in Stand-Alone
- -- libraries. If a library or the main program set the exception
- -- tracebacks, then they are never reset afterwards (see below).
-
- -- The value of main_priority is meaningful only when we are
- -- invoked from the main program elaboration routine of an Ada
- -- application. Checking the consistency of this parameter should
- -- therefore not be done. Since it is assured that the main
- -- program elaboration will always invoke this procedure before
- -- any library elaboration routine, only the value of
- -- main_priority during the first call should be taken into
- -- account and all the subsequent ones should be ignored. Note
- -- that the case where the main program is not written in Ada is
- -- also properly handled, since the default value will then be
- -- used for this parameter.
-
- -- For identical reasons, the consistency of time_slice_val should
- -- not be checked.
-
- if Already_Called then
- if (Gl_Locking_Policy /= Locking_Policy) or else
- (Gl_Queuing_Policy /= Queuing_Policy) or else
- (Gl_Task_Dispatching_Policy /= Task_Dispatching_Policy) or else
- (Gl_Unreserve_All_Interrupts /= Unreserve_All_Interrupts) or else
- (Gl_Exception_Tracebacks /= Exception_Tracebacks) or else
- (Gl_Zero_Cost_Exceptions /= Zero_Cost_Exceptions)
- then
- raise Program_Error;
- end if;
-
- -- If either a library or the main program set the exception
- -- traceback flag, it is never reset later.
-
- if Gl_Exception_Tracebacks /= 0 then
- Gl_Exception_Tracebacks := Exception_Tracebacks;
- end if;
-
- else
- Already_Called := True;
-
- Gl_Main_Priority := Main_Priority;
- Gl_Time_Slice_Val := Time_Slice_Value;
- Gl_Wc_Encoding := WC_Encoding;
- Gl_Locking_Policy := Locking_Policy;
- Gl_Queuing_Policy := Queuing_Policy;
- Gl_Task_Dispatching_Policy := Task_Dispatching_Policy;
- Gl_Restrictions := Restrictions;
- Gl_Interrupt_States := Interrupt_States;
- Gl_Num_Interrupt_States := Num_Interrupt_States;
- Gl_Unreserve_All_Interrupts := Unreserve_All_Interrupts;
- Gl_Exception_Tracebacks := Exception_Tracebacks;
- Gl_Zero_Cost_Exceptions := Zero_Cost_Exceptions;
- end if;
- end Set_Globals;
-
- ---------------------
- -- Install_Handler --
- ---------------------
-
- procedure Install_Handler is
- Mask : aliased sigset_t;
- Signal_Action : aliased struct_sigaction;
-
- Result : Interfaces.C.int;
- pragma Unreferenced (Result);
-
- begin
- -- Set up signal handler to map synchronous signals to appropriate
- -- exceptions. Make sure that the handler isn't interrupted by
- -- another signal that might cause a scheduling event!
-
- Signal_Action.sa_handler := GNAT_Error_Handler'Address;
- Signal_Action.sa_flags := SA_ONSTACK;
- Result := sigemptyset (Mask'Access);
- Signal_Action.sa_mask := Mask;
-
- Result := sigaction
- (Signal (SIGFPE), Signal_Action'Unchecked_Access, null);
-
- Result := sigaction
- (Signal (SIGILL), Signal_Action'Unchecked_Access, null);
-
- Result := sigaction
- (Signal (SIGSEGV), Signal_Action'Unchecked_Access, null);
-
- Result := sigaction
- (Signal (SIGBUS), Signal_Action'Unchecked_Access, null);
-
- Handler_Installed := 1;
- end Install_Handler;
-
-end System.Init;
+2004-02-12 Olivier Hainque <hainque@act-europe.fr>
+
+ * decl.c (components_to_record): Don't claim that the internal fields
+ we make to hold the variant parts are semantically addressable, because
+ they are not.
+
+ * exp_pakd.adb (Create_Packed_Array_Type): Rename Esiz into PASize and
+ adjust the comment describing the modular type form when we can use it.
+ (Install_PAT): Account for the Esiz renaming.
+
+ * init.c (__gnat_error_handler for alpha-tru64): Arrange to clear the
+ sc_onstack context indication before raising the exception to which
+ the signal is mapped. Allows better handling of later signals possibly
+ triggered by the resumed user code if the exception is handled.
+
+2004-02-12 Arnaud Charlet <charlet@act-europe.fr>
+
+ * 5zinit.adb: Removed, no longer used.
+
+2004-02-12 Robert Dewar <dewar@gnat.com>
+
+ * ali.adb: Remove separating space between parameters on R line. Makes
+ format consistent with format used by the binder for Set_Globals call.
+
+ * atree.ads, atree.adb: Minor reformatting (new function header format)
+
+ * bindgen.adb: Add Run-Time Globals documentation section containing
+ detailed documentation of the globals passed from the binder file to
+ the run time.
+
+ * gnatls.adb: Minor reformatting
+
+ * init.c (__gnat_set_globals): Add note pointing to documentation in
+ bindgen.
+
+ * lib-writ.ads, lib-writ.adb: Remove separating space between
+ parameters on R line.
+ Makes format consistent with format used by the binder for Set_Globals
+ call.
+
+ * osint.ads: Add 2004 to copyright notice
+ Minor reformatting
+
+ * snames.ads: Correct capitalization of FIFO_Within_Priorities
+ Noticed during code reading, documentation issue only
+
+ * usage.adb: Remove junk line for obsolete C switch
+ Noticed during code reading
+
+2004-02-12 Vincent Celier <celier@gnat.com>
+
+ * bld.adb (Process_Declarative_Items): For Source_Dirs call gprcmd
+ extend for each directory, so that multiple /** directories are
+ extended individually.
+ (Recursive_Process): Set the default for LANGUAGES to ada
+
+ * gprcmd.adb: Define new command "ignore", to do nothing.
+ Implement new comment "path".
+
+ * Makefile.generic: Suppress output when SILENT is set
+ Make sure that when compiler for C/C++ is gcc, the correct -x switch is
+ used, so that the correct compiler is invoked.
+ When compiler is gcc/g++, put search path in env vars C_INCLUDE_PATH/
+ CXX_INCLUDE_PATH, to avoid failure with too long command lines.
+
+2004-02-12 Jerome Guitton <guitton@act-europe.fr>
+
+ * Makefile.in: Clean ups and remove obsolete targets.
+
+2004-02-12 Ed Schonberg <schonberg@gnat.com>
+
+ * exp_ch5.adb: Remove Possible_Unligned_Slice, in favor of the similar
+ predicate declared in exp_util.
+
+ * exp_util.adb: Add comments.
+
+ * sem_ch10.adb (Analyze_Subunit): Remove ultimate parent unit from
+ visibility before compiling context of the subunit.
+
+ * sem_res.adb (Check_Parameterless_Call): If the context expects a
+ value but the name is a procedure, do not attempt to analyze as a call,
+ in order to obtain more telling diagnostics.
+
+ * sem_util.adb (Wrong_Type): Further enhancement to diagnose missing
+ 'Access on parameterless function calls.
+ (Normalize_Actuals): For a parameterless function call with missing
+ actuals, defer diagnostic until resolution of enclosing call.
+
+ * sem_util.adb (Wrong_Type): If the context type is an access to
+ subprogram and the expression is a procedure name, suggest a missing
+ 'attribute.
+
2004-02-10 Arnaud Charlet <charlet@act-europe.fr>,
Nathanael Nerode <neroden@gcc.gnu.org>
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
-
+
# GCC is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
-
+
# You should have received a copy of the GNU General Public License
# along with GCC; see the file COPYING. If not, write to
# the Free Software Foundation, 59 Temple Place - Suite 330,
# CXX name of the C++ compiler (optional, default to gcc)
# AR_CMD command to create an archive (optional, default to "ar rc")
# AR_EXT file extension of an archive (optional, default to ".a")
-# RANLIB command to generate an index (optional, default to "ranlib")
+# RANLIB command to generate an index (optional, default to "ranlib")
# GNATMAKE name of the GNAT builder (optional, default to "gnatmake")
# ADAFLAGS additional Ada compilation switches, e.g "-gnatf" (optional)
# CFLAGS default C compilation switches, e.g "-O2 -g" (optional)
# PROJECT_FILE name of the project file, without the .gpr extension
# DEPS_PROJECTS list of project dependencies (optional)
+# SILENT (optional) when defined, make -s will not output anything
+# when all commands are successful.
+
# Set the source search path for C and C++ if needed
ifndef MAIN
endif
ifndef GNATMAKE
- GNATMAKE=gnatmake
+ GNATMAKE:=gnatmake
endif
ifndef ARCHIVE
EXEC_DIR=$(OBJ_DIR)
endif
+# Define display to echo only when SILENT is not defined
+
+ifdef SILENT
+define display
+ @gprcmd ignore
+endef
+
+else
+define display
+ @echo
+endef
+endif
+
+# Make sure gnatmake is called silently when SILENT is set
+ifdef SILENT
+ GNATMAKE:=$(GNATMAKE) -q
+endif
+
+# If C/C++ compiler is gcc, make sure gcc is called with the switch indicating
+# the language, in case the extension is not standard.
+
+ifeq ($(strip $(filter-out %gcc,$(CC))),)
+ C_Compiler=$(CC) -x c
+else
+ C_Compiler=$(CC)
+endif
+
+ifeq ($(strip $(filter-out %gcc %g++,$(CXX))),)
+ CXX_Compiler=$(CXX) -x c++
+else
+ CXX_Compiler=$(CXX)
+endif
+
# Set the object search path
vpath %$(OBJ_EXT) $(OBJ_DIR)
endif
C_INCLUDES := $(foreach name,$(SRC_DIRS),-I$(name))
-ALL_CFLAGS = $(CFLAGS) $(C_INCLUDES) $(DEP_CFLAGS)
-ALL_CXXFLAGS = $(CXXFLAGS) $(C_INCLUDES) $(DEP_CFLAGS)
+ALL_CFLAGS = $(CFLAGS) $(DEP_CFLAGS)
+ALL_CXXFLAGS = $(CXXFLAGS) $(DEP_CFLAGS)
LDFLAGS := $(LIBS) $(LDFLAGS)
# Compute list of objects based on languages
internal-compile: lib$(PROJECT_BASE)$(AR_EXT)
lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS)
- @echo creating archive file for $(PROJECT_BASE)
+ @$(display) creating archive file for $(PROJECT_BASE)
cd $(OBJ_DIR); $(AR_CMD) $@ $(strip $(OBJECTS))
-$(RANLIB) $(OBJ_DIR)/$@
link: $(EXEC_DIR)/$(EXEC) archive-objects
$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
- @echo $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
+ @$(display) $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
$(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS)
endif
endif
ifeq ($(MAIN),ada)
# Ada main
link: $(LINKER) archive-objects force
- $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
+ @(display) $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES)
+ @$(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) archive-objects force
- @echo $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
+ @$(display) $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) -P$(PROJECT_FILE) $(EXEC_RULE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(LARGS) $(LDFLAGS)
# C/C++ main
link: $(LINKER) archive-objects force
- $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
+ @(display) $(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES)
+ @$(GNATMAKE) $(EXEC_RULE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) \
-largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
internal-build: $(LINKER) archive-objects force
- @echo $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
+ @$(display) $(GNATMAKE) -B -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
@$(GNATMAKE) $(EXEC_RULE) \
-B -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
-largs $(MAIN_OBJECT) $(LARGS) $(LDFLAGS)
# Automatic handling of dependencies
ifeq ($(strip $(filter-out %gcc %g++,$(CC) $(CXX))),)
-# Compiler is GCC, take avantage of the preprocessor option -MD
+# Compiler is GCC, take avantage of the preprocessor option -MD and
+# C*_INCLUDE_PATH environment variables
+
+export C_INCLUDE_PATH:=$(shell gprcmd path $(SRC_DIRS))$(C_INCLUDE_PATH)
+export CXX_INCLUDE_PATH:=$(shell gprcmd path $(SRC_DIRS))$(CXX_INCLUDE_PATH)
+
DEP_CFLAGS = -Wp,-MD,$(OBJ_DIR)/$(*F).d
define post-compile
else
# Compiler unknown, use a more general approach based on the output of $(CC) -M
+ALL_CFLAGS := $(ALL_CFLAGS) $(C_INCLUDES)
+ALL_CXXFLAGS := $(ALL_CXXFLAGS) $(C_INCLUDES)
+
DEP_FLAGS = -M
DEP_CFLAGS =
# Compile C files individually
%$(OBJ_EXT) : %$(C_EXT)
- @echo $(CC) -c $(CFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(display) $(C_Compiler) -c $(CFLAGS) $< -o $(OBJ_DIR)/$@
ifndef FAKE_COMPILE
- @$(CC) -c $(ALL_CFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(C_Compiler) -c $(ALL_CFLAGS) $< -o $(OBJ_DIR)/$@
@$(post-compile)
endif
# Compile C++ files individually
%$(OBJ_EXT) : %$(CXX_EXT)
- @echo $(CXX) -c $(CXXFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(display) $(CXX_Compiler) -c $(CXXFLAGS) $< -o $(OBJ_DIR)/$@
ifndef FAKE_COMPILE
- @$(CXX) -c $(ALL_CXXFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(CXX_Compiler) -c $(ALL_CXXFLAGS) $< -o $(OBJ_DIR)/$@
@$(post-compile)
endif
RTS_NAME=zfp RTS_SRCS="$(HIE_SOURCES)" \
RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
- -$(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
+ $(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
cd rts-zfp/adalib/ ; $(AR) r libgnat.a *.o
$(RM) rts-zfp/adalib/*.o
$(CHMOD) a-wx rts-zfp/adalib/*.ali
$(CHMOD) a-wx rts-zfp/adalib/libgnat.a
-rts-none: force
- $(MAKE) $(FLAGS_TO_PASS) prepare-rts \
- RTS_NAME=none RTS_SRCS="$(HIE_SOURCES)" \
- RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
- COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
- -$(GNATMAKE) -Prts-none/none.gpr --GCC="../../../xgcc -B../../../"
- $(RM) rts-none/adalib/*.o
- $(CHMOD) a-wx rts-none/adalib/*.ali
-
rts-ravenscar: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
RTS_NAME=ravenscar RTS_SRCS="$(RAVEN_SOURCES)" \
RTS_TARGET_PAIRS="$(HIE_RAVEN_TARGET_PAIRS)" \
COMPILABLE_SOURCES="$(COMPILABLE_RAVEN_SOURCES)"
- -$(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
+ $(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
--GCC="../../../xgcc -B../../../"
cd rts-ravenscar/adalib/ ; $(AR) r libgnat.a *.o
$(RM) rts-ravenscar/adalib/*.o
end case;
end loop;
- -- Skip separating space
-
- Checkc (' ');
-
-- Acquire information for parameter restrictions
for RP in All_Parameter_Restrictions loop
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty)
- return Node_Id
+ New_Scope : Entity_Id := Empty) return Node_Id
is
Actual_Map : Elist_Id := Map;
-- This is the actual map for the copy. It is initialized with the
-- Builds hash tables (number of elements >= threshold value)
function Copy_Elist_With_Replacement
- (Old_Elist : Elist_Id)
- return Elist_Id;
+ (Old_Elist : Elist_Id) return Elist_Id;
-- Called during second phase to copy element list doing replacements.
procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
---------------------------------
function Copy_Elist_With_Replacement
- (Old_Elist : Elist_Id)
- return Elist_Id
+ (Old_Elist : Elist_Id) return Elist_Id
is
M : Elmt_Id;
New_Elist : Elist_Id;
--------------------------------
function Copy_List_With_Replacement
- (Old_List : List_Id)
- return List_Id
+ (Old_List : List_Id) return List_Id
is
New_List : List_Id;
E : Node_Id;
--------------------------------
function Copy_Node_With_Replacement
- (Old_Node : Node_Id)
- return Node_Id
+ (Old_Node : Node_Id) return Node_Id
is
New_Node : Node_Id;
function Copy_Field_With_Replacement
- (Field : Union_Id)
- return Union_Id;
+ (Field : Union_Id) return Union_Id;
-- Given Field, which is a field of Old_Node, return a copy of it
-- if it is a syntactic field (i.e. its parent is Node), setting
-- the parent of the copy to poit to New_Node. Otherwise returns
---------------------------------
function Copy_Field_With_Replacement
- (Field : Union_Id)
- return Union_Id
+ (Field : Union_Id) return Union_Id
is
begin
if Field = Union_Id (Empty) then
function New_Entity
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Entity_Id
+ New_Sloc : Source_Ptr) return Entity_Id
is
Ent : Entity_Id;
function New_Node
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Node_Id
+ New_Sloc : Source_Ptr) return Node_Id
is
Nod : Node_Id;
function New_Node
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Node_Id;
+ New_Sloc : Source_Ptr) return Node_Id;
-- Allocates a completely new node with the given node type and source
-- location values. All other fields are set to their standard defaults:
--
function New_Entity
(New_Node_Kind : Node_Kind;
- New_Sloc : Source_Ptr)
- return Entity_Id;
+ New_Sloc : Source_Ptr) return Entity_Id;
-- Similar to New_Node, except that it is used only for entity nodes
-- and returns an extended node.
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty)
- return Node_Id;
+ New_Scope : Entity_Id := Empty) return Node_Id;
-- Given a node that is the root of a subtree, Copy_Tree copies the entire
-- syntactic subtree, including recursively any descendents whose parent
-- field references a copied node (descendents not linked to a copied node
Table_Increment => 200,
Table_Name => "IS_Pragma_Settings");
+ ----------------------
+ -- Run-Time Globals --
+ ----------------------
+
+ -- This section documents the global variables that are passed to the
+ -- run time from the generated binder file. The call that is made is
+ -- to the routine Set_Globals, which has the following spec:
+
+ -- procedure Set_Globals
+ -- (Main_Priority : Integer;
+ -- Time_Slice_Value : Integer;
+ -- WC_Encoding : Character;
+ -- Locking_Policy : Character;
+ -- Queuing_Policy : Character;
+ -- Task_Dispatching_Policy : Character;
+ -- Restrictions : System.Address;
+ -- Interrupt_States : System.Address;
+ -- Num_Interrupt_States : Integer;
+ -- Unreserve_All_Interrupts : Integer;
+ -- Exception_Tracebacks : Integer;
+ -- Zero_Cost_Exceptions : Integer);
+
+ -- Main_Priority is the priority value set by pragma Priority in the
+ -- main program. If no such pragma is present, the value is -1.
+
+ -- Time_Slice_Value is the time slice value set by pragma Time_Slice
+ -- in the main program, or by the use of a -Tnnn parameter for the
+ -- binder (if both are present, the binder value overrides). The
+ -- value is in milliseconds. A value of zero indicates that time
+ -- slicing should be suppressed. If no pragma is present, and no
+ -- -T switch was used, the value is -1.
+
+ -- WC_Encoding shows the wide character encoding method used for
+ -- the main program. This is one of the encoding letters defined
+ -- in System.WCh_Con.WC_Encoding_Letters.
+
+ -- Locking_Policy is a space if no locking policy was specified
+ -- for the partition. If a locking policy was specified, the value
+ -- is the upper case first character of the locking policy name,
+ -- for example, 'C' for Ceiling_Locking.
+
+ -- Queuing_Policy is a space if no queuing policy was specified
+ -- for the partition. If a queuing policy was specified, the value
+ -- is the upper case first character of the queuing policy name
+ -- for example, 'F' for FIFO_Queuing.
+
+ -- Task_Dispatching_Policy is a space if no task dispatching policy
+ -- was specified for the partition. If a task dispatching policy
+ -- was specified, the value is the upper case first character of
+ -- the policy name, e.g. 'F' for FIFO_Within_Priorities.
+
+ -- Restrictions is the address of a null-terminated string specifying the
+ -- restrictions information for the partition. The format is identical to
+ -- that of the parameter string found on R lines in ali files (see Lib.Writ
+ -- spec in lib-writ.ads for full details). The difference is that in this
+ -- context the values are the cumulative ones for the entire partition.
+
+ -- Interrupt_States is the address of a string used to specify the
+ -- cumulative results of Interrupt_State pragmas used in the partition.
+ -- The length of this string is determined by the last interrupt for which
+ -- such a pragma is given (the string will be a null string if no pragmas
+ -- were used). If pragma were present the entries apply to the interrupts
+ -- in sequence from the first interrupt, and are set to one of four
+ -- possible settings: 'n' for not specified, 'u' for user, 'r' for
+ -- run time, 's' for system, see description of Interrupt_State pragma
+ -- for further details.
+
+ -- Num_Interrupt_States is the length of the Interrupt_States string.
+ -- It will be set to zero if no Interrupt_State pragmas are present.
+
+ -- Unreserve_All_Interrupts is set to one if at least one unit in the
+ -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise.
+
+ -- Exception_Tracebacks is set to one if the -E parameter was present
+ -- in the bind and to zero otherwise. Note that on some targets exception
+ -- tracebacks are provided by default, so a value of zero for this
+ -- parameter does not necessarily mean no trace backs are available.
+
+ -- Zero_Cost_Exceptions is set to one if zero cost exceptions are used for
+ -- this partition, and to zero if longjmp/setjmp exceptions are used.
+ -- the use of zero
+
-----------------------
-- Local Subprograms --
-----------------------
-- being an absolute directory name.
Put (Project_Name &
- ".src_dirs:=$(shell gprcmd extend $(");
- Put (Project_Name);
- Put (".base_dir) '$(");
+ ".src_dirs:=$(foreach name,$(");
Put_Attribute (Project, Pkg, Item_Name, No_Name);
- Put_Line (")')");
+ Put ("),$(shell gprcmd extend $(");
+ Put (Project_Name);
+ Put_Line (".base_dir) '$(name)'))");
elsif Item_Name = Snames.Name_Source_Files then
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.
? TYPE_SIZE (gnu_record_type) : 0),
(all_rep_and_size
? bitsize_zero_node : 0),
- 1);
+ 0);
DECL_INTERNAL_P (gnu_field) = 1;
DECL_QUALIFIER (gnu_field) = gnu_qual;
= create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
packed,
all_rep ? TYPE_SIZE (gnu_union_type) : 0,
- all_rep ? bitsize_zero_node : 0, 1);
+ all_rep ? bitsize_zero_node : 0, 0);
DECL_INTERNAL_P (gnu_union_field) = 1;
TREE_CHAIN (gnu_union_field) = gnu_field_list;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Validsw; use Validsw;
-- an object. Such objects can be aliased to parameters (unlike local
-- array references).
- function Possible_Unaligned_Slice (Arg : Node_Id) return Boolean;
- -- Returns True if Arg (either the left or right hand side of the
- -- assignment) is a slice that could be unaligned wrt the array type.
- -- This is true if Arg is a component of a packed record, or is
- -- a record component to which a component clause applies. This
- -- is a little pessimistic, but the result of an unnecessary
- -- decision that something is possibly unaligned is only to
- -- generate a front end loop, which is not so terrible.
- -- It would really be better if backend handled this ???
-
-----------------------
-- Apply_Dereference --
-----------------------
and then Is_Non_Local_Array (Prefix (Exp)));
end Is_Non_Local_Array;
- ------------------------------
- -- Possible_Unaligned_Slice --
- ------------------------------
-
- function Possible_Unaligned_Slice (Arg : Node_Id) return Boolean is
- begin
- -- No issue if this is not a slice, or else strict alignment
- -- is not required in any case.
-
- if Nkind (Arg) /= N_Slice
- or else not Target_Strict_Alignment
- then
- return False;
- end if;
-
- -- No issue if the component type is a byte or byte aligned
-
- declare
- Array_Typ : constant Entity_Id := Etype (Arg);
- Comp_Typ : constant Entity_Id := Component_Type (Array_Typ);
- Pref : constant Node_Id := Prefix (Arg);
-
- begin
- if Known_Alignment (Array_Typ) then
- if Alignment (Array_Typ) = 1 then
- return False;
- end if;
-
- elsif Known_Component_Size (Array_Typ) then
- if Component_Size (Array_Typ) = 1 then
- return False;
- end if;
-
- elsif Known_Esize (Comp_Typ) then
- if Esize (Comp_Typ) <= System_Storage_Unit then
- return False;
- end if;
- end if;
-
- -- No issue if this is not a selected component
-
- if Nkind (Pref) /= N_Selected_Component then
- return False;
- end if;
-
- -- Else we test for a possibly unaligned component
-
- return
- Is_Packed (Etype (Pref))
- or else
- Present (Component_Clause (Entity (Selector_Name (Pref))));
- end;
- end Possible_Unaligned_Slice;
-
-- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs);
elsif Is_Bit_Packed_Array (L_Type)
or else Is_Bit_Packed_Array (R_Type)
- or else Possible_Unaligned_Slice (Lhs)
- or else Possible_Unaligned_Slice (Rhs)
+ or else Is_Possibly_Unaligned_Slice (Lhs)
+ or else Is_Possibly_Unaligned_Slice (Rhs)
then
Loop_Required := True;
Ancest : Entity_Id;
PB_Type : Entity_Id;
- Esiz : Uint;
+ PASize : Uint;
Decl : Node_Id;
PAT : Entity_Id;
Len_Dim : Node_Id;
-- Do not reset RM_Size if already set, as happens in the case
-- of a modular type.
- Set_Esize (PAT, Esiz);
+ Set_Esize (PAT, PASize);
if Unknown_RM_Size (PAT) then
- Set_RM_Size (PAT, Esiz);
+ Set_RM_Size (PAT, PASize);
end if;
-- Set remaining fields of packed array type
-- type, since this size clearly belongs to the packed array type. The
-- size of the conceptual unpacked type is always set to unknown.
- Esiz := Esize (Typ);
+ PASize := Esize (Typ);
-- Case of an array where at least one index is of an enumeration
-- type with a non-standard representation, but the component size
-- We can use the modular type, it has the form:
-- subtype tttPn is btyp
- -- range 0 .. 2 ** (Esize (Typ) * Csize) - 1;
+ -- range 0 .. 2 ** ((Typ'Length (1)
+ -- * ... * Typ'Length (n)) * Csize) - 1;
-- The bounds are statically known, and btyp is one
-- of the unsigned types, depending on the length. If the
Make_Integer_Literal (Loc, 0),
High_Bound => Lit))));
- if Esiz = Uint_0 then
- Esiz := Len_Bits;
+ if PASize = Uint_0 then
+ PASize := Len_Bits;
end if;
Install_PAT;
function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean is
begin
+ -- ??? GCC3 will eventually handle strings with arbitrary alignments,
+ -- but for now the following check must be disabled.
+
+ -- if get_gcc_version >= 3 then
+ -- return False;
+ -- end if;
+
if Is_Entity_Name (P)
and then Is_Object (Entity (P))
and then Present (Renamed_Object (Entity (P)))
Print_Unit : Boolean := True;
Print_Source : Boolean := True;
Print_Object : Boolean := True;
- -- Flags controlling the form of the outpout
+ -- Flags controlling the form of the output
- Dependable : Boolean := False; -- flag -d
- Also_Predef : Boolean := False;
+ Dependable : Boolean := False; -- flag -d
+ Also_Predef : Boolean := False;
Unit_Start : Integer;
Unit_End : Integer;
-- updated to the full file name if available.
function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id;
- -- Give the Sdep entry corresponding to the unit U in ali record A.
+ -- Give the Sdep entry corresponding to the unit U in ali record A
procedure Output_Object (O : File_Name_Type);
-- Print out the name of the object when requested
procedure Output_Source (Sdep_I : Sdep_Id);
-- Print out the name and status of the source corresponding to this
- -- sdep entry
+ -- sdep entry.
procedure Output_Status (FS : File_Status; Verbose : Boolean);
-- Print out FS either in a coded form if verbose is false or in an
-- Reset Print flags properly when selective output is chosen
procedure Scan_Ls_Arg (Argv : String; And_Save : Boolean);
- -- Scan and process lser specific arguments. Argv is a single argument.
+ -- Scan and process lser specific arguments. Argv is a single argument
procedure Usage;
- -- Print usage message.
+ -- Print usage message
-----------------
-- Add_Lib_Dir --
-- Verify is output is not wider than maximum number of columns
- Too_Long := Verbose_Mode or else
- (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column;
+ Too_Long :=
+ Verbose_Mode
+ or else
+ (Max_Unit_Length + Max_Src_Length + Max_Obj_Length) > Max_Column;
- -- Set start and end of columns.
+ -- Set start and end of columns
Object_Start := 1;
Object_End := Object_Start - 1;
Namet.Initialize;
Csets.Initialize;
- -- Use low level argument routines to avoid dragging in the secondary stack
+ -- Loop to scan out arguments
Next_Arg := 1;
-
Scan_Args : while Next_Arg < Arg_Count loop
declare
Next_Argv : String (1 .. Len_Arg (Next_Arg));
end loop;
Find_General_Layout;
+
for Id in ALIs.First .. ALIs.Last loop
declare
Last_U : Unit_Id;
end if;
end loop;
- -- Print out list of dependable units
+ -- Print out list of units on which this unit depends (D lines)
if Dependable and then Print_Source then
if Verbose_Mode then
-- 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;
"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 " &
+ "convert a directory list into a path list");
+ Put_Line (Standard_Error, " ignore " &
+ "do nothing");
OS_Exit (1);
end Usage;
begin
if Cmd = "-v" then
- -- Should this be on Standard_Error ???
+ -- Output on standard error, because only returned values should
+ -- go to standard output.
Put (Standard_Error, "GPRCMD ");
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
end if;
end;
+ -- For "path" just add path separator after each directory argument
+
+ elsif Cmd = "path" then
+ for J in 2 .. Argument_Count loop
+ Put (Argument (J));
+ Put (Path_Separator);
+ end loop;
+
+ -- For "ignore" do nothing
+
+ elsif Cmd = "ignore" then
+ null;
+
-- Unknown command
else
installed by this file are used to handle resulting signals that come
from these probes failing (i.e. touching protected pages) */
+/* This file should be kept synchronized with 2sinit.ads, 2sinit.adb, and
+ 5zinit.adb. All these files implement the required functionality for
+ different targets. */
+
/* The following include is here to meet the published VxWorks requirement
that the __vxworks header appear before any other include. */
#ifdef __vxworks
binder file is not in the shared library. Global references across library
boundaries like this are not handled correctly in all systems. */
+/* For detailed description of the parameters to this routine, see the
+ section titled Run-Time Globals in package Bindgen (bindgen.adb) */
+
void
__gnat_set_globals (int main_priority,
int time_slice_val,
exclude this case in the above test. */
#include <signal.h>
+#include <setjmp.h>
#include <sys/siginfo.h>
static void __gnat_error_handler (int, siginfo_t *, struct sigcontext *);
if (mstate != 0)
*mstate = *context;
- Raise_From_Signal_Handler (exception, (char *) msg);
+ /* We are now going to raise the exception corresponding to the signal we
+ caught, which may eventually end up resuming the application code if the
+ exception is handled.
+
+ When the exception is handled, merely arranging for the *exception*
+ handler's context (stack pointer, program counter, other registers, ...)
+ to be installed is *not* enough to let the kernel think we've left the
+ *signal* handler. This has annoying implications if an alternate stack
+ has been setup for this *signal* handler, because the kernel thinks we
+ are still running on that alternate stack even after the jump, which
+ causes trouble at least as soon as another signal is raised.
+
+ We deal with this by forcing a "local" longjmp within the signal handler
+ below, forcing the "on alternate stack" indication to be reset (kernel
+ wise) on the way. If no alternate stack has been setup, this should be a
+ neutral operation. Otherwise, we will be in a delicate situation for a
+ short while because we are going to run the exception propagation code
+ within the alternate stack area (that is, with the stack pointer inside
+ the alternate stack bounds), but with the corresponding flag off from the
+ kernel's standpoint. We expect this to be ok as long as the propagation
+ code does not trigger a signal itself, which is expected.
+
+ ??? A better approach would be to at least delay this operation until the
+ last second, that is, until just before we jump to the exception handler,
+ if any. */
+ {
+ jmp_buf handler_jmpbuf;
+
+ if (setjmp (handler_jmpbuf) != 0)
+ Raise_From_Signal_Handler (exception, (char *) msg);
+ else
+ {
+ /* Arrange for the "on alternate stack" flag to be reset. See the
+ comments around "jmp_buf offsets" in /usr/include/setjmp.h. */
+ struct sigcontext * handler_context
+ = (struct sigcontext *) & handler_jmpbuf;
+
+ handler_context->sc_onstack = 0;
+
+ longjmp (handler_jmpbuf, 1);
+ }
+ }
}
void
we want this to happen for tasks also. */
static char sig_stack [8*1024];
- /* 8K allocated here because 4K is not enough for the GCC/ZCX scheme. */
+ /* 8K is a mininum to be able to propagate an exception using the GCC/ZCX
+ scheme. */
struct sigaltstack ss;
- ss.ss_sp = (void *) & sig_stack;
+ ss.ss_sp = (void *) sig_stack;
ss.ss_size = sizeof (sig_stack);
ss.ss_flags = 0;
end if;
end loop;
- -- A separating space
-
- Write_Info_Char (' ');
-
-- And now the information for the parameter restrictions
for RP in All_Parameter_Restrictions loop
-- has been able to determine with respect to restrictions violations.
-- The format is:
- -- R <<restriction-characters>> space <<restriction-param-id-entries>>
+ -- R <<restriction-characters>> <<restriction-param-id-entries>>
-- The first parameter is a string of characters that records
-- information regarding restrictions that do not take parameter
-- has "v", which is not permitted, since these restrictions
-- are partition-wide.
- -- Following a space, the second parameter refers to restriction
- -- identifiers for which a parameter is given.
+ -- The second parameter, which immediately follows the first (with
+ -- no separating space) gives restriction information for identifiers
+ -- for which a parameter is given.
-- The parameter is a string of entries, one for each value in
-- Restrict.All_Parameter_Restrictions. Each entry has two
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- 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- --
type File_Type is (Source, Library, Config, Definition, Preprocessing_Data);
function Find_File
- (N : File_Name_Type;
- T : File_Type)
- return File_Name_Type;
+ (N : File_Name_Type;
+ T : File_Type) return File_Name_Type;
-- Finds a source, library or config file depending on the value
-- of T following the directory search order rules unless N is the
-- name of the file just read with Next_Main_File and already
function To_Canonical_File_List
(Wildcard_Host_File : String;
- Only_Dirs : Boolean)
- return String_Access_List_Access;
+ Only_Dirs : Boolean) return String_Access_List_Access;
-- Expand a wildcard host syntax file or directory specification (e.g. on
-- a VMS host, any file or directory spec that contains:
-- "*", or "%", or "...")
function To_Canonical_Dir_Spec
(Host_Dir : String;
- Prefix_Style : Boolean)
- return String_Access;
+ Prefix_Style : Boolean) return String_Access;
-- Convert a host syntax directory specification (e.g. on a VMS host:
-- "SYS$DEVICE:[DIR]") to canonical (Unix) syntax (e.g. "/sys$device/dir").
-- If Prefix_Style then make it a valid file specification prefix.
-- this simply means the spec has a trailing slash ("/").
function To_Canonical_File_Spec
- (Host_File : String)
- return String_Access;
+ (Host_File : String) return String_Access;
-- Convert a host syntax file specification (e.g. on a VMS host:
-- "SYS$DEVICE:[DIR]FILE.EXT;69 to canonical (Unix) syntax (e.g.
-- "/sys$device/dir/file.ext.69").
function To_Canonical_Path_Spec
- (Host_Path : String)
- return String_Access;
+ (Host_Path : String) return String_Access;
-- Convert a host syntax Path specification (e.g. on a VMS host:
-- "SYS$DEVICE:[BAR],DISK$USER:[FOO] to canonical (Unix) syntax (e.g.
-- "/sys$device/foo:disk$user/foo").
function To_Host_Dir_Spec
(Canonical_Dir : String;
- Prefix_Style : Boolean)
- return String_Access;
+ Prefix_Style : Boolean) return String_Access;
-- Convert a canonical syntax directory specification to host syntax.
-- The Prefix_Style flag is currently ignored but should be set to
-- False.
function To_Host_File_Spec
- (Canonical_File : String)
- return String_Access;
+ (Canonical_File : String) return String_Access;
-- Convert a canonical syntax file specification to host syntax.
function Relocate_Path
-- replace the Prefix substring with the root installation directory.
-- By default, try to compute the root installation directory by looking
-- at the executable name as it was typed on the command line and, if
- -- needed, use the PATH environment variable.
- -- If the above computation fails, return Path.
- -- This function assumes that Prefix'First = Path'First
+ -- needed, use the PATH environment variable. If the above computation
+ -- fails, return Path. This function assumes Prefix'First = Path'First.
function Shared_Lib (Name : String) return String;
-- Returns the runtime shared library in the form -l<name>-<version> where
procedure Get_Next_Dir_In_Path_Init
(Search_Path : String_Access);
function Get_Next_Dir_In_Path
- (Search_Path : String_Access)
- return String_Access;
+ (Search_Path : String_Access) return String_Access;
-- These subprograms are used to parse out the directory names in a
-- search path specified by a Search_Path argument. The procedure
-- initializes an internal pointer to point to the initial directory
function Get_RTS_Search_Dir
(Search_Dir : String;
- File_Type : Search_File_Type)
- return String_Ptr;
+ File_Type : Search_File_Type) return String_Ptr;
-- This function retrieves the paths to the search (resp. lib) dirs and
-- return them. The search dir can be absolute or relative. If the search
-- dir contains Include_Search_File (resp. Object_Search_File), then this
-- called Source_File_Data (Cache => True). See below.
function Matching_Full_Source_Name
- (N : File_Name_Type;
- T : Time_Stamp_Type)
- return File_Name_Type;
+ (N : File_Name_Type;
+ T : Time_Stamp_Type) return File_Name_Type;
-- Same semantics than Full_Source_Name but will search on the source
-- path until a source file with time stamp matching T is found. If
-- none is found returns No_File.
function Read_Library_Info
(Lib_File : File_Name_Type;
- Fatal_Err : Boolean := False)
- return Text_Buffer_Ptr;
+ Fatal_Err : Boolean := False) return Text_Buffer_Ptr;
-- Allocates a Text_Buffer of appropriate length and reads in the entire
-- source of the library information from the library information file
-- whose name is given by the parameter Name.
end if;
end if;
+ Set_Is_Immediately_Visible (Par_Unit, False);
+
Analyze_Subunit_Context;
+
Re_Install_Parents (Lib_Unit, Par_Unit);
+ Set_Is_Immediately_Visible (Par_Unit);
-- If the context includes a child unit of the parent of the
-- subunit, the parent will have been removed from visibility,
Require_Entity (N);
end if;
+ -- If the context expects a value, and the name is a procedure,
+ -- this is most likely a missing 'Access. Do not try to resolve
+ -- the parameterless call, error will be caught when the outer
+ -- call is analyzed.
+
+ if Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Procedure
+ and then not Is_Overloaded (N)
+ and then
+ (Nkind (Parent (N)) = N_Parameter_Association
+ or else Nkind (Parent (N)) = N_Function_Call
+ or else Nkind (Parent (N)) = N_Procedure_Call_Statement)
+ then
+ return;
+ end if;
+
-- Rewrite as call if overloadable entity that is (or could be, in
-- the overloaded case) a function call. If we know for sure that
-- the entity is an enumeration literal, we do not rewrite it.
or else Sloc (S) = Standard_Location)
and then Is_Overloadable (S)
then
- Error_Msg_Name_1 := Chars (S);
- Error_Msg_Sloc := Sloc (S);
- Error_Msg_NE
- ("missing argument for parameter & " &
- "in call to % declared #", N, Formal);
+ if No (Actuals)
+ and then
+ (Nkind (Parent (N)) = N_Procedure_Call_Statement
+ or else
+ (Nkind (Parent (N)) = N_Function_Call
+ or else
+ Nkind (Parent (N)) = N_Parameter_Association))
+ then
+ Set_Etype (N, Etype (S));
+ else
+ Error_Msg_Name_1 := Chars (S);
+ Error_Msg_Sloc := Sloc (S);
+ Error_Msg_NE
+ ("missing argument for parameter & " &
+ "in call to % declared #", N, Formal);
+ end if;
elsif Is_Overloadable (S) then
Error_Msg_Name_1 := Chars (S);
- -- Point to type derivation that
- -- generated the operation.
+ -- Point to type derivation that generated the
+ -- operation.
Error_Msg_Sloc := Sloc (Parent (S));
or else
Ekind (Entity (Expr)) = E_Generic_Procedure)
then
- Error_Msg_N ("found procedure name instead of function!", Expr);
+ if Ekind (Expec_Type) = E_Access_Subprogram_Type then
+ Error_Msg_N
+ ("found procedure name, possibly missing Access attribute!",
+ Expr);
+ else
+ Error_Msg_N ("found procedure name instead of function!", Expr);
+ end if;
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Ekind (Expec_Type) = E_Access_Subprogram_Type
+ and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
+ and then No (Parameter_Associations (Expr))
+ then
+ Error_Msg_N
+ ("found function name, possibly missing Access attribute!",
+ Expr);
-- catch common error: a prefix or infix operator which is not
-- directly visible because the type isn't.
-- are added, the first character must be distinct.
First_Task_Dispatching_Policy_Name : constant Name_Id := N + 440;
- Name_Fifo_Within_Priorities : constant Name_Id := N + 440;
+ Name_FIFO_Within_Priorities : constant Name_Id := N + 440;
Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 440;
-- Names of recognized checks for pragma Suppress
Write_Switch_Char ("c");
Write_Line ("Check syntax and semantics only (no code generation)");
- Write_Switch_Char ("C");
- Write_Line ("Compress names in external names and debug info tables");
-
-- Line for -gnatd switch
Write_Switch_Char ("d?");
projects / platform / upstream / gcc.git / commitdiff