+2004-08-09 Thomas Quinot <quinot@act-europe.fr>
+
+ * g-socket.adb (Abort_Selector): Initialize Buf to prevent valgrind
+ from complaining on potential uninitialized reference.
+ Change calls to GNAT.Sockets.Thin.Is_Socket_In_Set to account for
+ new specification and test explicitly for non-zero return value.
+
+ * g-socthi.ads (Is_Socket_In_Set): Declare imported function as
+ returning C.int, to avoid using a derived boolean type.
+
+ * exp_ch5.adb (Make_Tag_Ctrl_Assignments): Use
+ Duplicate_Subexpr_No_Checks in preference to direct use of
+ Remove_Side_Effects and New_Copy_Tree.
+ Clear Comes_From_Source on prefix of 'Size attribute reference.
+
+ * g-socthi.adb, g-socthi-vms.adb, g-socthi-mingw.adb,
+ g-socthi-vxworks.adb: Change calls to
+ GNAT.Sockets.Thin.Is_Socket_In_Set to account for new specification
+ and test explicitly for non-zero return value.
+
+ * g-socthi-vms.ads, g-socthi-mingw.ads, g-socthi-vxworks.ads:
+ (Is_Socket_In_Set): Declare imported function as returning C.int, to
+ avoid using a derived boolean type.
+
+2004-08-09 Albert Lee <lee@gnat.com>
+
+ * system-irix-n32.ads: Refine tasking priority constants for IRIX.
+
+2004-08-09 Pascal Obry <obry@gnat.com>
+
+ * gnat_ugn.texi: Document new way to build DLLs on Windows using
+ GCC's -shared option.
+
+ * mlib-tgt-mingw.adb (Build_Dynamic_Library): Pass GCC's options into
+ Options_2 parameter (options put after object files).
+
+2004-08-09 Olivier Hainque <hainque@act-europe.fr>
+
+ * decl.c (gnat_to_gnu_entity) <E_Array_Subtype>: Adjust condition to
+ ignore overflows on low and high bounds of an index to also account for
+ differences in signedness between sizetype and gnu_index_subtype.
+ These are as legitimate as the ones caused by a lower TYPE_PRECISION
+ on sizetype.
+
+2004-08-09 Robert Dewar <dewar@gnat.com>
+
+ * s-solita.ads, s-solita.adb: Minor reformatting
+
+ * gnat_rm.texi: Add documentation for pragma Profile (Restricted)
+ Move pragma Restricted_Run_Time, No_Run_Time, Ravenscar to new
+ obsolescent section
+ Add note that No_Implicit_Conditionals does not suppress
+ run time constraint checks.
+
+ * vms_conv.ads: Minor reformatting
+
+ * s-secsta.adb: Use SS_Ptr instead of Mark_Id as stack pointer (cleanup
+ and necessary for following change).
+ (Mark): Return new format Mark_Id containing sec stack address
+ (Release): Use sec stack address from Mark_Id avoiding Self call
+
+ * s-secsta.ads: Define SS_Ptr to be used instead of Mark_Id as stack
+ pointer (cleanup and necessary for following change).
+ Define Mark_Id as record containing address of secondary stack, that way
+ Release does not need to find the stack again, decreasing the number of
+ calls to Self and improving efficiency.
+
+ * sem_util.ads: Add a ??? comment for Is_Local_Variable_Reference
+
+ * sem_ch5.adb (Analyze_Case_Statement): Add circuitry to track value of
+ case variable into the individual case branches when possible.
+
+ * sem_ch11.adb: Minor reformatting
+
+ * prj.ads: Correct spelling of suffixs
+
+ * prj-nmsc.adb: Minor reformatting
+ Correct spelling suffixs throughout (also in identifiers)
+
+ * freeze.adb: Minor spelling correction
+
+ * exp_ch2.adb: Cleanups to handling of Current_Value
+ (no functional effect).
+
+ * bld.adb: Correct spelling of suffixs
+
+ * einfo.adb (Enclosing_Dynamic_Scope): Defend against junk argument
+
+2004-08-09 Ed Schonberg <schonberg@gnat.com>
+
+ PR ada/15408
+
+ * sem_ch7.adb (Install_Private_Declarations): In the body of the
+ package or of a child, private entities are both immediately_visible
+ and not hidden.
+
+2004-08-09 Ed Schonberg <schonberg@gnat.com>
+
+ * sem_eval.adb (Eval_Integer_Literal): If the context is Any_Integer,
+ there are no range checks on the value of the literal.
+
+ * exp_ch7.adb (Insert_Actions_In_Scope_Around): If the node being
+ wrapped is the triggering alternative of an asynchronous select, action
+ statements mustbe inserted before the select itself.
+
+ * sem_attr.adb (Analyze_Attribute, case 'Size): Handle properly the
+ case where the prefix is a protected function call.
+ (Resolve_Attribute, case 'Access): The attribute reference on a
+ subprogram is legal in a generic body if the subprogram is declared
+ elsewhere.
+
+2004-08-09 Vincent Celier <celier@gnat.com>
+
+ * makegpr.adb (Build_Library): Link with g++ if C++ is one of the
+ languages, otherwise building the library may fail with unresolved
+ symbols.
+ (Compile_Sources): Do not build libraries if -c switch is used
+
+ * gnatlink.adb (Process_Args): New switches -M and -Mmap
+ (Write_Usage): If map file creation is supported, output new switches
+ -M and -Mmap.
+ (Gnatlink): When -M is specified, add the necessary switch(es) to the
+ gcc call, when supported.
+
+ * Makefile.in: Added indepsw.o to the object list for gnatlink
+ Specified the AIX, GNU/Linux and Windows versions of indepsw.adb
+
+ * indepsw-aix.adb, indepsw-linux.adb, indepsw-mingw.adb,
+ indepsw.adb, indepsw.ads: New files.
+
+2004-08-09 Bernard Banner <banner@gnat.com>
+
+ * system-vxworks-x86.ads, s-vxwork-x86.ads: New files.
+
+ * Makefile.in: add section for vxworks x86
+
+2004-08-09 Hristian Kirtchev <kirtchev@gnat.com>
+
+ * exp_ch3.adb (Build_Init_Statements): Add extra condition to deal with
+ per-object constrained components where the discriminant is of an
+ Access type.
+ (Build_Record_Init_Proc): Add condition to prevent the inheritance of
+ the parent initialization procedure for derived Unchecked_Unions.
+ Instead, derived Unchecked_Unions build their own initialization
+ procedure.
+ (Build_Variant_Record_Equality): Implement Unchecked_Union equality.
+ Check the body of the subprogram for details.
+ (Freeze_Record_Type): Prevent the inheritance of discriminant checking
+ functions for derived Unchecked_Union types by introducing a condition.
+ Allow the creation of TSS equality functions for Unchecked_Unions.
+ (Make_Eq_Case): Rename formal parameter Node to E in function signature.
+ Add formal parameter Discr to function signature. Discr is used to
+ control the generated case statement for Unchecked_Union types.
+ (Make_Eq_If): Rename formal parameter Node to E in function signature.
+
+ * exp_ch4.adb (Build_Equality_Call): Implement equality calls for
+ Unchecked_Unions.
+ Check the body of the subprogram for details.
+ (Expand_Composite_Equality): Augment composite type equality to include
+ correct handling of Unchecked_Union components.
+ (Expand_N_In): Add condition to detect illegal membership tests when the
+ subtype mark is a constrained Unchecked_Union and the expression lacks
+ inferable discriminants, and build a Raise_Program_Error node.
+ (Expand_N_Op_Eq): Add function Has_Unconstrained_UU_Component. Used
+ to detect types that contain components of unconstrained Unchecked_Union
+ subtype. Add condition to detect equality between types that have an
+ unconstrained Unchecked_Union component, and build a Raise_Program_Error
+ node. Add condition to detect equality between Unchecked_Union types
+ that lack inferable discriminants, and build a Raise_Program_Error node.
+ Otherwise build a TSS equality function call.
+ (Expand_N_Type_Conversion): Add condition to detect illegal conversions
+ from a derived Unchecked_Union to an unconstrained non-Unchecked_Union
+ with the operand lacking inferable discriminants, and build a Raise_
+ Program_Error node.
+ (Expand_Record_Equality): Remove guard that prevents Unchecked_Union
+ composite equality.
+ (Has_Inferable_Discriminants): Implement new predicate for objects and
+ expressions of Unchecked_Union type. Check the body of subprogram for
+ details.
+ (Has_Unconstrained_UU_Components): Add function
+ Component_Is_Unconstrained_UU. It is used to detect whether a single
+ component is of an unconstrained Unchecked_Union subtype. Add function
+ Variant_Is_Unconstrained_UU. It is used to detect whether a single
+ component inside a variant is of an unconstrained Unchecked_Union type.
+
+ * exp_ch5.adb (Expand_Assign_Record): Add condition to copy the
+ inferred discriminant values. Add condition to generate a case
+ statement with an inferred discriminant as the switch.
+ (Make_Component_List_Assign): Introduce a Boolean flag that determines
+ the behaviour of the subprogram in the presence of an Unchecked_Union.
+ Add condition to trigger the usage of the inferred discriminant value
+ as the generated case statement switch.
+ (Make_Field_Assign): Introduce a Boolean flag that determines the
+ behaviour of the subprogram in the presence of an Unchecked_Union. Add
+ condition to trigger the usage of the inferred discriminant value as
+ the right-hand side of the generated assignment.
+
+ * exp_ch6.adb (Expand_Call): Add condition to skip extra actual
+ parameter generation when dealing with Unchecked_Unions.
+
+ * checks.adb (Apply_Discriminant_Check): Do not apply discriminant
+ checks for Unchecked_Unions.
+
+ * einfo.ads: Update comment on usage of flag Has_Per_Object_Constraint
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Produce
+ Raise_Program_Error nodes for the execution of Read and Write
+ attributes of Unchecked_Union types and the execution of Input and
+ Output attributes of Unchecked_Union types that lack default
+ discriminant values.
+
+ * sem_prag.adb (Analyze_Pragma): Remodel the analysis of pragma
+ Unchecked_Union. Add procedure Check_Component. It is used to inspect
+ per-object constrained components of Unchecked_Unions for being
+ Unchecked_Unions themselves. Add procedure Check_Variant. It is used to
+ check individual components withing a variant.
+
+ * sem_res.adb (Resolve_Comparison_Op): Remove guard that prevents
+ comparison of Unchecked_Unions.
+ (Resolve_Equality_OP): Remove guard that prevents equality between
+ Unchecked_Unions.
+
+ * sem_util.adb (Build_Component_Subtype): Add guard to prevent creation
+ of component subtypes for Unchecked_Union components.
+ (Get_Actual_Subtype): Add condition that returs the Unchecked_Union type
+ since it is the actual subtype.
+
+ * sem_ch12.adb (Instantiate_Type): Add condition to detect the correct
+ pass of Unchecked_Union subtypes as generic actuals to formal types
+ that lack known_discriminant_parts or that are derived Unchecked_Union
+ types, and do nothing. In any other case, produce an error message.
+
+ * sem_ch3.adb (Analyze_Component_Declaration): Add function
+ Contains_POC. It determines whether a constraint uses the discriminant
+ of an enclosing record type.
+ Add condition to detect per-object constrained component and set the
+ appropriate flag.
+ (Derived_Type_Declaration): Remove guard that prevents derivation from
+ Unchecked_Union types.
+ (Process_Subtype): Remove quard that prevents the creation of Unchecked_
+ Union subtypes.
+
+ * sem_ch4.adb (Analyze_Selected_Component): Correct the detection of
+ references to Unchecked_Union discriminants.
+
+ * sem_ch6.adb (Create_Extra_Formals): Add condition to skip extra
+ formal generation when dealing with Unchecked_Unions.
+ (Set_Actual_Subtypes): Add condition to prevent generation of actual
+ subtypes for Unchecked_Unions.
+
+ * sem_ch7.adb (Analyze_Package_Specification): Add procedure
+ Inspect_Unchecked_Union_Completion. It is used to detect incorrect
+ completions of discriminated partial views by Unchecked_Unions and
+ produce an error message.
+
+2004-08-09 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
+
+ * trans.c (struct stmt_group): New field, GLOBAL.
+ (global_stmt_group, gnu_elab_proc_decl, build_unit_elab): Deleted.
+ (struct elab_info): New struct.
+ (elab_info_list, gnu_elab_proc_stack): New variables.
+ (Compilation_Unit_to_gnu): New procedure.
+ (gigi): Call it and also handle elaboration procs we've saved.
+ (gnat_init_stmt_group): Don't set global_stmt_group; instead initialize
+ global field from parent.
+ (gnat_to_gnu): Get decl from gnu_elab_proc_stack.
+ (gnat_to_gnu, case N_Compilation_Unit): Call Compilation_Unit_to_gnu.
+ (start_stmt_group): Initialize global field from parent.
+ (add_decl_expr): Set to global for current statement group.
+ (gnat_gimplify_expr, case NULL_EXPR): Add operand 0 to pre list, not
+ post.
+
+ * utils.c (global_bindings_p): True when no current_function_decl; no
+ longer check current_binding_level.
+
+2004-08-09 Ben Brosgol <brosgol@gnat.com>
+
+ * xgnatugn.adb: Added logic to deal with @ifset/@ifclear for edition
+ choice.
+
+ * gnat_rm.texi, gnat_ugn.texi: Added edition conditionalization logic.
+
2004-08-06 Andreas Schwab <schwab@suse.de>
* utils.c (gnat_define_builtin): Remove second parameter of
GNATLINK_OBJS = gnatlink.o \
a-except.o ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o gnatvsn.o \
- hostparm.o interfac.o i-c.o i-cstrin.o namet.o opt.o osint.o output.o rident.o \
+ hostparm.o indepsw.o interfac.o i-c.o i-cstrin.o namet.o opt.o osint.o output.o rident.o \
s-exctab.o s-secsta.o s-stalib.o s-stoele.o sdefault.o stylesw.o switch.o system.o \
table.o tree_io.o types.o validsw.o widechar.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
endif
+ifeq ($(strip $(filter-out %86 wrs vxworks,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-sytaco.ads<a-sytaco-vxworks.ads \
+ a-sytaco.adb<a-sytaco-vxworks.adb \
+ a-intnam.ads<a-intnam-vxworks.ads \
+ s-inmaop.adb<s-inmaop-posix.adb \
+ s-interr.adb<s-interr-vxworks.adb \
+ s-intman.ads<s-intman-vxworks.ads \
+ s-intman.adb<s-intman-vxworks.adb \
+ a-numaux.adb<a-numaux-x86.adb \
+ a-numaux.ads<a-numaux-x86.ads \
+ s-osinte.adb<s-osinte-vxworks.adb \
+ s-osinte.ads<s-osinte-vxworks.ads \
+ s-osprim.adb<s-osprim-vxworks.adb \
+ s-parame.ads<s-parame-vxworks.ads \
+ s-stchop.adb<s-stchop-vxworks.adb \
+ s-taprop.adb<s-taprop-vxworks.adb \
+ s-taspri.ads<s-taspri-vxworks.ads \
+ s-tpopsp.adb<s-tpopsp-vxworks.adb \
+ s-vxwork.ads<s-vxwork-x86.ads \
+ g-soccon.ads<g-soccon-vxworks.ads \
+ g-socthi.ads<g-socthi-vxworks.ads \
+ g-socthi.adb<g-socthi-vxworks.adb \
+ system.ads<system-vxworks-x86.ads
+
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
+
+ ifeq ($(strip $(filter-out yes,$(TRACE))),)
+ LIBGNAT_TARGET_PAIRS += \
+ s-traces.adb<s-traces-default.adb \
+ s-trafor.adb<s-trafor-default.adb \
+ s-trafor.ads<s-trafor-default.ads \
+ s-tratas.adb<s-tratas-default.adb \
+ s-tfsetr.adb<s-tfsetr-vxworks.adb
+ endif
+
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
+endif
+
ifeq ($(strip $(filter-out xscale% coff wrs vx%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \
a-sytaco.ads<a-sytaco-vxworks.ads \
system.ads<system-linux-x86.ads
TOOLS_TARGET_PAIRS = \
- mlib-tgt.adb<mlib-tgt-linux.adb
+ mlib-tgt.adb<mlib-tgt-linux.adb \
+ indepsw.adb<indepsw-linux.adb
SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB = -lpthread
THREADSLIB = -lgthreads -lmalloc
endif
- TOOLS_TARGET_PAIRS = mlib-tgt.adb<mlib-tgt-aix.adb
+ TOOLS_TARGET_PAIRS = \
+ mlib-tgt.adb<mlib-tgt-aix.adb \
+ indepsw.adb<indepsw-aix.adb
+
GMEM_LIB = gmemlib
SYMLIB = $(ADDR2LINE_SYMLIB)
g-soliop.ads<g-soliop-mingw.ads \
system.ads<system-mingw.ads
- TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-mingw.adb
+ TOOLS_TARGET_PAIRS= \
+ mlib-tgt.adb<mlib-tgt-mingw.adb \
+ indepsw.adb<indepsw-mingw.adb
+
MISCLIB = -lwsock32
SYMLIB = $(ADDR2LINE_SYMLIB)
GMEM_LIB = gmemlib
Expression_Value : String_Access := new String (1 .. 10);
Expression_Last : Natural := 0;
- -- The following variables indicates if the suffixs and the languages
+ -- 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);
There_Are_Cases := Last_Case /= Last_Case_Construction;
- -- If the suffixs and the languages have not been specified,
+ -- 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
end if;
-- If we still don't know the language, and all
- -- suffixs are static, then it cannot any of the
+ -- suffixes are static, then it cannot any of the
-- processed languages.
if Source_Kind = Unknown
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
+with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
return;
end if;
+ -- Nothing to do if the type is an Unchecked_Union
+
+ if Is_Unchecked_Union (Base_Type (T_Typ)) then
+ return;
+ end if;
+
-- Suppress checks if the subtypes are the same.
-- the check must be preserved in an assignment to a formal, because
-- the constraint is given by the actual.
Dval := Duplicate_Subexpr_No_Checks (Dval);
end if;
- Dref :=
- Make_Selected_Component (Loc,
- Prefix =>
- Duplicate_Subexpr_No_Checks (N, Name_Req => True),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Disc_Ent)));
+ -- If we have an Unchecked_Union node, we can infer the discriminants
+ -- of the node.
+
+ if Is_Unchecked_Union (Base_Type (T_Typ)) then
+ Dref := New_Copy (
+ Get_Discriminant_Value (
+ First_Discriminant (T_Typ),
+ T_Typ,
+ Stored_Constraint (T_Typ)));
+
+ else
+ Dref :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (N, Name_Req => True),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Disc_Ent)));
- Set_Is_In_Discriminant_Check (Dref);
+ Set_Is_In_Discriminant_Check (Dref);
+ end if;
Evolve_Or_Else (Cond,
Make_Op_Ne (Loc,
not a deferred constant but a constant whose value is built
manually. */
- if (definition && !gnu_expr
+ if (definition && !gnu_expr
&& !No_Initialization (Declaration_Node (gnat_entity))
&& No (Renamed_Object (gnat_entity)))
{
does not overflow in SIZETYPE, ignore the overflow
indications. */
if ((TYPE_PRECISION (gnu_index_subtype)
- > TYPE_PRECISION (sizetype))
+ > TYPE_PRECISION (sizetype)
+ || TYPE_UNSIGNED (gnu_index_subtype)
+ != TYPE_UNSIGNED (sizetype))
&& TREE_CODE (gnu_min) == INTEGER_CST
&& TREE_CODE (gnu_max) == INTEGER_CST
&& TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
/* Similarly, if the range is null, use bounds of 1..0 for
the sizetype bounds. */
else if ((TYPE_PRECISION (gnu_index_subtype)
- > TYPE_PRECISION (sizetype))
+ > TYPE_PRECISION (sizetype)
+ || TYPE_UNSIGNED (gnu_index_subtype)
+ != TYPE_UNSIGNED (sizetype))
&& TREE_CODE (gnu_min) == INTEGER_CST
&& TREE_CODE (gnu_max) == INTEGER_CST
&& (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
else if (gnu_our_rep_list)
{
tree gnu_rep_type
- = (gnu_field_list ? gnu_record_type : make_node (RECORD_TYPE));
+ = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
int len = list_length (gnu_our_rep_list);
tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
int i;
S : Entity_Id;
begin
+ -- The following test is an error defense against some syntax
+ -- errors that can leave scopes very messed up.
+
+ if Id = Standard_Standard then
+ return Id;
+ end if;
+
+ -- Normal case, search enclosing scopes
+
S := Scope (Id);
while S /= Standard_Standard
and then not Is_Dynamic_Scope (S)
-- Has_Per_Object_Constraint (Flag154)
-- Present in E_Component entities, true if the subtype of the
--- component has a per object constraint, i.e. an actual discriminant
--- value of the form T'Access, where T is the enclosing type.
+-- component has a per object constraint. Per object constraints result
+-- from the following situations:
+--
+-- 1. N_Attribute_Reference - when the prefix is the enclosing type and
+-- the attribute is Access.
+-- 2. N_Discriminant_Association - when the expression uses the
+-- discriminant of the enclosing type.
+-- 3. N_Index_Or_Discriminant_Constraint - when at least one of the
+-- individual constraints is a per object constraint.
+-- 4. N_Range - when the lower or upper bound uses the discriminant of
+-- the enclosing type.
+-- 5. N_Range_Constraint - when the range expression uses the
+-- discriminant of the enclosing type.
-- Has_Pragma_Controlled (Flag27) [implementation base type only]
-- Present in access type entities. It is set if a pragma Controlled
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
+with Elists; use Elists;
with Exp_Ch2; use Exp_Ch2;
with Exp_Ch9; use Exp_Ch9;
with Exp_Imgv; use Exp_Imgv;
pragma Assert
(Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
+ -- Ada 2005 (AI-216): Program_Error is raised when executing
+ -- the default implementation of the Input attribute of an
+ -- unchecked union type if the type lacks default discriminant
+ -- values.
+
+ if Is_Unchecked_Union (Base_Type (U_Type))
+ and then not Present (Discriminant_Constraint (U_Type))
+ then
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+
+ return;
+ end if;
+
Build_Record_Or_Elementary_Input_Function
(Loc, Base_Type (U_Type), Decl, Fname);
Insert_Action (N, Decl);
pragma Assert
(Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
+ -- Ada 2005 (AI-216): Program_Error is raised when executing
+ -- the default implementation of the Output attribute of an
+ -- unchecked union type if the type lacks default discriminant
+ -- values.
+
+ if Is_Unchecked_Union (Base_Type (U_Type))
+ and then not Present (Discriminant_Constraint (U_Type))
+ then
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+
+ return;
+ end if;
+
Build_Record_Or_Elementary_Output_Procedure
(Loc, Base_Type (U_Type), Decl, Pname);
Insert_Action (N, Decl);
pragma Assert
(Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
+ -- Ada 2005 (AI-216): Program_Error is raised when executing
+ -- the default implementation of the Read attribute of an
+ -- Unchecked_Union type.
+
+ if Is_Unchecked_Union (Base_Type (U_Type)) then
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+ end if;
+
if Has_Discriminants (U_Type)
and then Present
(Discriminant_Default_Value (First_Discriminant (U_Type)))
then
Build_Mutable_Record_Read_Procedure
(Loc, Base_Type (U_Type), Decl, Pname);
-
else
Build_Record_Read_Procedure
(Loc, Base_Type (U_Type), Decl, Pname);
pragma Assert
(Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
+ -- Ada 2005 (AI-216): Program_Error is raised when executing
+ -- the default implementation of the Write attribute of an
+ -- Unchecked_Union type.
+
+ if Is_Unchecked_Union (Base_Type (U_Type)) then
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+ end if;
+
if Has_Discriminants (U_Type)
and then Present
(Discriminant_Default_Value (First_Discriminant (U_Type)))
then
Build_Mutable_Record_Write_Procedure
(Loc, Base_Type (U_Type), Decl, Pname);
-
else
Build_Record_Write_Procedure
(Loc, Base_Type (U_Type), Decl, Pname);
-- Given a node N for a variable whose Current_Value field is set.
-- If the node is for a discrete type, replaces the node with a
-- copy of the referenced value. This provides a limited form of
- -- value propagation for variables which are initialized and have
- -- not been modified at the time of reference. The call has no
- -- effect if the Current_Value refers to a conditional with a
+ -- value propagation for variables which are initialized or assigned
+ -- not been further modified at the time of reference. The call has
+ -- no effect if the Current_Value refers to a conditional with a
-- condition other than equality.
procedure Expand_Discriminant (N : Node_Id);
CS := Scope (CS);
-- Otherwise, the reference is dubious, and we cannot be
- -- sure that it is safe to do the replacement. Note in
- -- particular, in a loop (except for the special case
- -- tested above), we cannot safely do a replacement since
- -- there may be an assignment at the bottom of the loop
- -- that will affect a reference at the top of the loop.
+ -- sure that it is safe to do the replacement.
else
exit;
begin
if True
+ -- No replacement if value raises constraint error
+
+ and then Nkind (CV) /= N_Raise_Constraint_Error
+
-- Do this only for discrete types
and then Is_Discrete_Type (T)
or else
Ekind (E) = E_Out_Parameter)
and then Present (Current_Value (E))
- and then Nkind (Current_Value (E)) /= N_Raise_Constraint_Error
then
Expand_Current_Value (N);
-- Check if E is defined in the RTL (in a child of Ada or System). Used
-- to avoid to bring in the overhead of _Input, _Output for tagged types.
- function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id;
+ function Make_Eq_Case
+ (E : Entity_Id;
+ CL : Node_Id;
+ Discr : Entity_Id := Empty) return List_Id;
-- Building block for variant record equality. Defined to share the
-- code between the tagged and non-tagged case. Given a Component_List
-- node CL, it generates an 'if' followed by a 'case' statement that
-- compares all components of local temporaries named X and Y (that
- -- are declared as formals at some upper level). Node provides the
- -- Sloc to be used for the generated code.
+ -- are declared as formals at some upper level). E provides the Sloc to be
+ -- used for the generated code. Discr is used as the case statement switch
+ -- in the case of Unchecked_Union equality.
- function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id;
+ function Make_Eq_If
+ (E : Entity_Id;
+ L : List_Id) return Node_Id;
-- Building block for variant record equality. Defined to share the
-- code between the tagged and non-tagged case. Given the list of
-- components (or discriminants) L, it generates a return statement
-- that compares all components of local temporaries named X and Y
- -- (that are declared as formals at some upper level). Node provides
- -- the Sloc to be used for the generated code.
+ -- (that are declared as formals at some upper level). E provides the Sloc
+ -- to be used for the generated code.
procedure Make_Predefined_Primitive_Specs
(Tag_Typ : Entity_Id;
Id : Entity_Id;
Typ : Entity_Id;
+ function Has_Access_Constraint (E : Entity_Id) return Boolean;
+ -- Components with access discriminants that depend on the current
+ -- instance must be initialized after all other components.
+
+ ---------------------------
+ -- Has_Access_Constraint --
+ ---------------------------
+
+ function Has_Access_Constraint (E : Entity_Id) return Boolean is
+ Disc : Entity_Id;
+ T : constant Entity_Id := Etype (E);
+
+ begin
+ if Has_Per_Object_Constraint (E)
+ and then Has_Discriminants (T)
+ then
+ Disc := First_Discriminant (T);
+ while Present (Disc) loop
+ if Is_Access_Type (Etype (Disc)) then
+ return True;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ return False;
+ else
+ return False;
+ end if;
+ end Has_Access_Constraint;
+
+ -- Start of processing for Build_Init_Statements
+
begin
if Null_Present (Comp_List) then
return New_List (Make_Null_Statement (Loc));
Per_Object_Constraint_Components := False;
- -- First step : regular components.
+ -- First step : regular components
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
- if Has_Per_Object_Constraint (Id)
+ if Has_Access_Constraint (Id)
and then No (Expression (Decl))
then
-- Skip processing for now and ask for a second pass
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
- if Has_Per_Object_Constraint (Id)
+ if Has_Access_Constraint (Id)
and then No (Expression (Decl))
then
if Has_Non_Null_Base_Init_Proc (Typ) then
if Is_Derived_Type (Rec_Type)
and then not Is_Tagged_Type (Rec_Type)
+ and then not Is_Unchecked_Union (Rec_Type)
and then not Has_New_Non_Standard_Rep (Rec_Type)
and then not Parent_Subtype_Renaming_Discrims
and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type))
-- Otherwise if we need an initialization procedure, then build one,
-- mark it as public and inlinable and as having a completion.
- elsif Requires_Init_Proc (Rec_Type) then
+ elsif Requires_Init_Proc (Rec_Type)
+ or else Is_Unchecked_Union (Rec_Type)
+ then
Build_Init_Procedure;
Set_Is_Public (Proc_Id, Is_Public (Pe));
Def : constant Node_Id := Parent (Typ);
Comps : constant Node_Id := Component_List (Type_Definition (Def));
Stmts : constant List_Id := New_List;
+ Pspecs : constant List_Id := New_List;
begin
+ -- Derived Unchecked_Union types no longer inherit the equality function
+ -- of their parent.
+
if Is_Derived_Type (Typ)
+ and then not Is_Unchecked_Union (Typ)
and then not Has_New_Non_Standard_Rep (Typ)
then
declare
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => F,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => X,
- Parameter_Type => New_Reference_To (Typ, Loc)),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Y,
- Parameter_Type => New_Reference_To (Typ, Loc))),
-
+ Parameter_Specifications => Pspecs,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
-
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)));
- -- For unchecked union case, raise program error. This will only
- -- happen in the case of dynamic dispatching for a tagged type,
- -- since in the static cases it is a compile time error.
+ Append_To (Pspecs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => X,
+ Parameter_Type => New_Reference_To (Typ, Loc)));
+
+ Append_To (Pspecs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Y,
+ Parameter_Type => New_Reference_To (Typ, Loc)));
+
+ -- Unchecked_Unions require additional machinery to support equality.
+ -- Two extra parameters (A and B) are added to the equality function
+ -- parameter list in order to capture the inferred values of the
+ -- discriminants in later calls.
+
+ if Is_Unchecked_Union (Typ) then
+ declare
+ Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ));
+
+ A : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_A);
+
+ B : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_B);
+
+ begin
+ -- Add A and B to the parameter list
+
+ Append_To (Pspecs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => A,
+ Parameter_Type => New_Reference_To (Discr_Type, Loc)));
+
+ Append_To (Pspecs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => B,
+ Parameter_Type => New_Reference_To (Discr_Type, Loc)));
+
+ -- Generate the following header code to compare the inferred
+ -- discriminants:
+
+ -- if a /= b then
+ -- return False;
+ -- end if;
+
+ Append_To (Stmts,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Reference_To (A, Loc),
+ Right_Opnd => New_Reference_To (B, Loc)),
+ Then_Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Standard_False, Loc)))));
+
+ -- Generate component-by-component comparison. Note that we must
+ -- propagate one of the inferred discriminant formals to act as
+ -- the case statement switch.
+
+ Append_List_To (Stmts,
+ Make_Eq_Case (Typ, Comps, A));
+
+ end;
+
+ -- Normal case (not unchecked union)
- if Has_Unchecked_Union (Typ) then
- Append_To (Stmts,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Unchecked_Union_Restriction));
else
Append_To (Stmts,
Make_Eq_If (Typ,
Discriminant_Specifications (Def)));
+
Append_List_To (Stmts,
Make_Eq_Case (Typ, Comps));
end if;
elsif Is_Derived_Type (Def_Id)
and then not Is_Tagged_Type (Def_Id)
+
+ -- If we have a derived Unchecked_Union, we do not inherit the
+ -- discriminant checking functions from the parent type since the
+ -- discriminants are non existent.
+
+ and then not Is_Unchecked_Union (Def_Id)
and then Has_Discriminants (Def_Id)
then
declare
begin
if Present (Comps)
and then Present (Variant_Part (Comps))
- and then not Is_Unchecked_Union (Def_Id)
then
Build_Variant_Record_Equality (Def_Id);
end if;
-- when Vn => <Make_Eq_Case> on subcomponents
-- end case;
- function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Node);
+ function Make_Eq_Case
+ (E : Entity_Id;
+ CL : Node_Id;
+ Discr : Entity_Id := Empty) return List_Id
+ is
+ Loc : constant Source_Ptr := Sloc (E);
Result : constant List_Id := New_List;
Variant : Node_Id;
Alt_List : List_Id;
begin
- Append_To (Result, Make_Eq_If (Node, Component_Items (CL)));
+ Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
if No (Variant_Part (CL)) then
return Result;
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
- Statements => Make_Eq_Case (Node, Component_List (Variant))));
+ Statements => Make_Eq_Case (E, Component_List (Variant))));
Next_Non_Pragma (Variant);
end loop;
- Append_To (Result,
- Make_Case_Statement (Loc,
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_X),
- Selector_Name => New_Copy (Name (Variant_Part (CL)))),
- Alternatives => Alt_List));
+ -- If we have an Unchecked_Union, use one of the parameters that
+ -- captures the discriminants.
+
+ if Is_Unchecked_Union (E) then
+ Append_To (Result,
+ Make_Case_Statement (Loc,
+ Expression => New_Reference_To (Discr, Loc),
+ Alternatives => Alt_List));
+
+ else
+ Append_To (Result,
+ Make_Case_Statement (Loc,
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_X),
+ Selector_Name => New_Copy (Name (Variant_Part (CL)))),
+ Alternatives => Alt_List));
+ end if;
return Result;
end Make_Eq_Case;
-- or a null statement if the list L is empty
- function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id is
- Loc : constant Source_Ptr := Sloc (Node);
+ function Make_Eq_If
+ (E : Entity_Id;
+ L : List_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (E);
C : Node_Id;
Field_Name : Name_Id;
Cond : Node_Id;
else
return
- Make_Implicit_If_Statement (Node,
+ Make_Implicit_If_Statement (E,
Condition => Cond,
Then_Statements => New_List (
Make_Return_Statement (Loc,
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
-- for created object. If context is an access parameter, create a
-- local access type to have a usable finalization list.
+ function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
+ -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
+ -- discriminants if it has a constrained nominal type, unless the object
+ -- is a component of an enclosing Unchecked_Union object that is subject
+ -- to a per-object constraint and the enclosing object lacks inferable
+ -- discriminants.
+ --
+ -- An expression of an Unchecked_Union type has inferable discriminants
+ -- if it is either a name of an object with inferable discriminants or a
+ -- qualified expression whose subtype mark denotes a constrained subtype.
+
procedure Insert_Dereference_Action (N : Node_Id);
-- N is an expression whose type is an access. When the type of the
-- associated storage pool is derived from Checked_Pool, generate a
end;
else
+ -- Comparison between Unchecked_Union components
+
+ if Is_Unchecked_Union (Full_Type) then
+ declare
+ Lhs_Type : Node_Id := Full_Type;
+ Rhs_Type : Node_Id := Full_Type;
+ Lhs_Discr_Val : Node_Id;
+ Rhs_Discr_Val : Node_Id;
+
+ begin
+ -- Lhs subtype
+
+ if Nkind (Lhs) = N_Selected_Component then
+ Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
+ end if;
+
+ -- Rhs subtype
+
+ if Nkind (Rhs) = N_Selected_Component then
+ Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
+ end if;
+
+ -- Lhs of the composite equality
+
+ if Is_Constrained (Lhs_Type) then
+
+ -- Since the enclosing record can never be an
+ -- Unchecked_Union (this code is executed for records
+ -- that do not have variants), we may reference its
+ -- discriminant(s).
+
+ if Nkind (Lhs) = N_Selected_Component
+ and then Has_Per_Object_Constraint (
+ Entity (Selector_Name (Lhs)))
+ then
+ Lhs_Discr_Val :=
+ Make_Selected_Component (Loc,
+ Prefix => Prefix (Lhs),
+ Selector_Name =>
+ New_Copy (
+ Get_Discriminant_Value (
+ First_Discriminant (Lhs_Type),
+ Lhs_Type,
+ Stored_Constraint (Lhs_Type))));
+
+ else
+ Lhs_Discr_Val := New_Copy (
+ Get_Discriminant_Value (
+ First_Discriminant (Lhs_Type),
+ Lhs_Type,
+ Stored_Constraint (Lhs_Type)));
+
+ end if;
+ else
+ -- It is not possible to infer the discriminant since
+ -- the subtype is not constrained.
+
+ Insert_Action (Nod,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+
+ -- Prevent Gigi from generating illegal code, change
+ -- the equality to a standard False.
+
+ return New_Occurrence_Of (Standard_False, Loc);
+ end if;
+
+ -- Rhs of the composite equality
+
+ if Is_Constrained (Rhs_Type) then
+ if Nkind (Rhs) = N_Selected_Component
+ and then Has_Per_Object_Constraint (
+ Entity (Selector_Name (Rhs)))
+ then
+ Rhs_Discr_Val :=
+ Make_Selected_Component (Loc,
+ Prefix => Prefix (Rhs),
+ Selector_Name =>
+ New_Copy (
+ Get_Discriminant_Value (
+ First_Discriminant (Rhs_Type),
+ Rhs_Type,
+ Stored_Constraint (Rhs_Type))));
+
+ else
+ Rhs_Discr_Val := New_Copy (
+ Get_Discriminant_Value (
+ First_Discriminant (Rhs_Type),
+ Rhs_Type,
+ Stored_Constraint (Rhs_Type)));
+
+ end if;
+ else
+ Insert_Action (Nod,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+
+ return Empty;
+ end if;
+
+ -- Call the TSS equality function with the inferred
+ -- discriminant values.
+
+ return
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Eq_Op, Loc),
+ Parameter_Associations => New_List (
+ Lhs,
+ Rhs,
+ Lhs_Discr_Val,
+ Rhs_Discr_Val));
+ end;
+ end if;
+
+ -- Shouldn't this be an else, we can't fall through
+ -- the above IF, right???
+
return
Make_Function_Call (Loc,
Name => New_Reference_To (Eq_Op, Loc),
Prefix => New_Reference_To (Typ, Loc))));
Analyze_And_Resolve (N, Rtyp);
return;
+
+ -- Ada 2005 (AI-216): Program_Error is raised when evaluating
+ -- a membership test if the subtype mark denotes a constrained
+ -- Unchecked_Union subtype and the expression lacks inferable
+ -- discriminants.
+
+ elsif Is_Unchecked_Union (Base_Type (Typ))
+ and then Is_Constrained (Typ)
+ and then not Has_Inferable_Discriminants (Lop)
+ then
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+
+ -- Prevent Gigi from generating incorrect code by rewriting
+ -- the test as a standard False.
+
+ Rewrite (N,
+ New_Occurrence_Of (Standard_False, Loc));
+
+ return;
end if;
-- Here we have a non-scalar type
-- build and analyze call, adding conversions if the operation is
-- inherited.
+ function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
+ -- Determines whether a type has a subcompoment of an unconstrained
+ -- Unchecked_Union subtype. Typ is a record type.
+
-------------------------
-- Build_Equality_Call --
-------------------------
R_Exp := OK_Convert_To (Op_Type, R_Exp);
end if;
- Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Reference_To (Eq, Loc),
- Parameter_Associations => New_List (L_Exp, R_Exp)));
+ -- If we have an Unchecked_Union, we need to add the inferred
+ -- discriminant values as actuals in the function call. At this
+ -- point, the expansion has determined that both operands have
+ -- inferable discriminants.
+
+ if Is_Unchecked_Union (Op_Type) then
+ declare
+ Lhs_Type : constant Node_Id := Etype (L_Exp);
+ Rhs_Type : constant Node_Id := Etype (R_Exp);
+ Lhs_Discr_Val : Node_Id;
+ Rhs_Discr_Val : Node_Id;
+
+ begin
+ -- Per-object constrained selected components require special
+ -- attention. If the enclosing scope of the component is an
+ -- Unchecked_Union, we can not reference its discriminants
+ -- directly. This is why we use the two extra parameters of
+ -- the equality function of the enclosing Unchecked_Union.
+
+ -- type UU_Type (Discr : Integer := 0) is
+ -- . . .
+ -- end record;
+ -- pragma Unchecked_Union (UU_Type);
+
+ -- 1. Unchecked_Union enclosing record:
+
+ -- type Enclosing_UU_Type (Discr : Integer := 0) is record
+ -- . . .
+ -- Comp : UU_Type (Discr);
+ -- . . .
+ -- end Enclosing_UU_Type;
+ -- pragma Unchecked_Union (Enclosing_UU_Type);
+
+ -- Obj1 : Enclosing_UU_Type;
+ -- Obj2 : Enclosing_UU_Type (1);
+
+ -- . . . Obj1 = Obj2 . . .
+
+ -- Generated code:
+
+ -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
+
+ -- A and B are the formal parameters of the equality function
+ -- of Enclosing_UU_Type. The function always has two extra
+ -- formals to capture the inferred discriminant values.
+
+ -- 2. Non-Unchecked_Union enclosing record:
+
+ -- type
+ -- Enclosing_Non_UU_Type (Discr : Integer := 0)
+ -- is record
+ -- . . .
+ -- Comp : UU_Type (Discr);
+ -- . . .
+ -- end Enclosing_Non_UU_Type;
+
+ -- Obj1 : Enclosing_Non_UU_Type;
+ -- Obj2 : Enclosing_Non_UU_Type (1);
+
+ -- . . . Obj1 = Obj2 . . .
+
+ -- Generated code:
+
+ -- if not (uu_typeEQ (obj1.comp, obj2.comp,
+ -- obj1.discr, obj2.discr)) then
+
+ -- In this case we can directly reference the discriminants of
+ -- the enclosing record.
+
+ -- Lhs of equality
+
+ if Nkind (Lhs) = N_Selected_Component
+ and then Has_Per_Object_Constraint (
+ Entity (Selector_Name (Lhs)))
+ then
+ -- Enclosing record is an Unchecked_Union, use formal A
+
+ if Is_Unchecked_Union (Scope
+ (Entity (Selector_Name (Lhs))))
+ then
+ Lhs_Discr_Val :=
+ Make_Identifier (Loc,
+ Chars => Name_A);
+
+ -- Enclosing record is of a non-Unchecked_Union type, it is
+ -- possible to reference the discriminant.
+
+ else
+ Lhs_Discr_Val :=
+ Make_Selected_Component (Loc,
+ Prefix => Prefix (Lhs),
+ Selector_Name =>
+ New_Copy (Get_Discriminant_Value (
+ First_Discriminant (Lhs_Type),
+ Lhs_Type,
+ Stored_Constraint (Lhs_Type))));
+
+ end if;
+
+ -- Comment needed here ???
+
+ else
+ -- Infer the discriminant value
+
+ Lhs_Discr_Val :=
+ New_Copy (Get_Discriminant_Value (
+ First_Discriminant (Lhs_Type),
+ Lhs_Type,
+ Stored_Constraint (Lhs_Type)));
+
+ end if;
+
+ -- Rhs of equality
+
+ if Nkind (Rhs) = N_Selected_Component
+ and then Has_Per_Object_Constraint (
+ Entity (Selector_Name (Rhs)))
+ then
+ if Is_Unchecked_Union (Scope
+ (Entity (Selector_Name (Rhs))))
+ then
+ Rhs_Discr_Val :=
+ Make_Identifier (Loc,
+ Chars => Name_B);
+
+ else
+ Rhs_Discr_Val :=
+ Make_Selected_Component (Loc,
+ Prefix => Prefix (Rhs),
+ Selector_Name =>
+ New_Copy (Get_Discriminant_Value (
+ First_Discriminant (Rhs_Type),
+ Rhs_Type,
+ Stored_Constraint (Rhs_Type))));
+
+ end if;
+ else
+ Rhs_Discr_Val :=
+ New_Copy (Get_Discriminant_Value (
+ First_Discriminant (Rhs_Type),
+ Rhs_Type,
+ Stored_Constraint (Rhs_Type)));
+
+ end if;
+
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Eq, Loc),
+ Parameter_Associations => New_List (
+ L_Exp,
+ R_Exp,
+ Lhs_Discr_Val,
+ Rhs_Discr_Val)));
+ end;
+
+ -- Normal case, not an unchecked union
+
+ else
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Eq, Loc),
+ Parameter_Associations => New_List (L_Exp, R_Exp)));
+ end if;
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end Build_Equality_Call;
+ ------------------------------------
+ -- Has_Unconstrained_UU_Component --
+ ------------------------------------
+
+ function Has_Unconstrained_UU_Component
+ (Typ : Node_Id) return Boolean
+ is
+ Tdef : constant Node_Id :=
+ Type_Definition (Declaration_Node (Typ));
+ Clist : Node_Id;
+ Vpart : Node_Id;
+
+ function Component_Is_Unconstrained_UU
+ (Comp : Node_Id) return Boolean;
+ -- Determines whether the subtype of the component is an
+ -- unconstrained Unchecked_Union.
+
+ function Variant_Is_Unconstrained_UU
+ (Variant : Node_Id) return Boolean;
+ -- Determines whether a component of the variant has an unconstrained
+ -- Unchecked_Union subtype.
+
+ -----------------------------------
+ -- Component_Is_Unconstrained_UU --
+ -----------------------------------
+
+ function Component_Is_Unconstrained_UU
+ (Comp : Node_Id) return Boolean
+ is
+ begin
+ if Nkind (Comp) /= N_Component_Declaration then
+ return False;
+ end if;
+
+ declare
+ Sindic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (Comp));
+
+ begin
+ -- Unconstrained nominal type. In the case of a constraint
+ -- present, the node kind would have been N_Subtype_Indication.
+
+ if Nkind (Sindic) = N_Identifier then
+ return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
+ end if;
+
+ return False;
+ end;
+ end Component_Is_Unconstrained_UU;
+
+ ---------------------------------
+ -- Variant_Is_Unconstrained_UU --
+ ---------------------------------
+
+ function Variant_Is_Unconstrained_UU
+ (Variant : Node_Id) return Boolean
+ is
+ Clist : constant Node_Id := Component_List (Variant);
+
+ begin
+ if Is_Empty_List (Component_Items (Clist)) then
+ return False;
+ end if;
+
+ declare
+ Comp : Node_Id := First (Component_Items (Clist));
+
+ begin
+ while Present (Comp) loop
+
+ -- One component is sufficent
+
+ if Component_Is_Unconstrained_UU (Comp) then
+ return True;
+ end if;
+
+ Next (Comp);
+ end loop;
+ end;
+
+ -- None of the components withing the variant were of
+ -- unconstrained Unchecked_Union type.
+
+ return False;
+ end Variant_Is_Unconstrained_UU;
+
+ -- Start of processing for Has_Unconstrained_UU_Component
+
+ begin
+ if Null_Present (Tdef) then
+ return False;
+ end if;
+
+ Clist := Component_List (Tdef);
+ Vpart := Variant_Part (Clist);
+
+ -- Inspect available components
+
+ if Present (Component_Items (Clist)) then
+ declare
+ Comp : Node_Id := First (Component_Items (Clist));
+
+ begin
+ while Present (Comp) loop
+
+ -- One component is sufficent
+
+ if Component_Is_Unconstrained_UU (Comp) then
+ return True;
+ end if;
+
+ Next (Comp);
+ end loop;
+ end;
+ end if;
+
+ -- Inspect available components withing variants
+
+ if Present (Vpart) then
+ declare
+ Variant : Node_Id := First (Variants (Vpart));
+
+ begin
+ while Present (Variant) loop
+
+ -- One component within a variant is sufficent
+
+ if Variant_Is_Unconstrained_UU (Variant) then
+ return True;
+ end if;
+
+ Next (Variant);
+ end loop;
+ end;
+ end if;
+
+ -- Neither the available components, nor the components inside the
+ -- variant parts were of an unconstrained Unchecked_Union subtype.
+
+ return False;
+ end Has_Unconstrained_UU_Component;
+
-- Start of processing for Expand_N_Op_Eq
begin
Build_Equality_Call (Op_Name);
+ -- Ada 2005 (AI-216): Program_Error is raised when evaluating the
+ -- predefined equality operator for a type which has a subcomponent
+ -- of an Unchecked_Union type whose nominal subtype is unconstrained.
+
+ elsif Has_Unconstrained_UU_Component (Typl) then
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+
+ -- Prevent Gigi from generating incorrect code by rewriting the
+ -- equality as a standard False.
+
+ Rewrite (N,
+ New_Occurrence_Of (Standard_False, Loc));
+
+ elsif Is_Unchecked_Union (Typl) then
+
+ -- If we can infer the discriminants of the operands, we make a
+ -- call to the TSS equality function.
+
+ if Has_Inferable_Discriminants (Lhs)
+ and then
+ Has_Inferable_Discriminants (Rhs)
+ then
+ Build_Equality_Call
+ (TSS (Root_Type (Typl), TSS_Composite_Equality));
+
+ else
+ -- Ada 2005 (AI-216): Program_Error is raised when evaluating
+ -- the predefined equality operator for an Unchecked_Union type
+ -- if either of the operands lack inferable discriminants.
+
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction));
+
+ -- Prevent Gigi from generating incorrect code by rewriting
+ -- the equality as a standard False.
+
+ Rewrite (N,
+ New_Occurrence_Of (Standard_False, Loc));
+
+ end if;
+
-- If a type support function is present (for complex cases), use it
elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
-- assignment processing.
elsif Is_Record_Type (Target_Type) then
- Handle_Changed_Representation;
+
+ -- Ada 2005 (AI-216): Program_Error is raised when converting from
+ -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
+ -- Union type if the operand lacks inferable discriminants.
+
+ if Is_Derived_Type (Operand_Type)
+ and then Is_Unchecked_Union (Base_Type (Operand_Type))
+ and then not Is_Constrained (Target_Type)
+ and then not Is_Unchecked_Union (Base_Type (Target_Type))
+ and then not Has_Inferable_Discriminants (Operand)
+ then
+ -- To prevent Gigi from generating illegal code, we make a
+ -- Program_Error node, but we give it the target type of the
+ -- conversion.
+
+ declare
+ PE : constant Node_Id := Make_Raise_Program_Error (Loc,
+ Reason => PE_Unchecked_Union_Restriction);
+
+ begin
+ Set_Etype (PE, Target_Type);
+ Rewrite (N, PE);
+
+ end;
+ else
+ Handle_Changed_Representation;
+ end if;
-- Case of conversions of enumeration types
-- Start of processing for Expand_Record_Equality
begin
- -- Special processing for the unchecked union case, which will occur
- -- only in the context of tagged types and dynamic dispatching, since
- -- other cases are handled statically. We return True, but insert a
- -- raise Program_Error statement.
-
- if Is_Unchecked_Union (Typ) then
-
- -- If this is a component of an enclosing record, return the Raise
- -- statement directly.
-
- if No (Parent (Lhs)) then
- Result :=
- Make_Raise_Program_Error (Loc,
- Reason => PE_Unchecked_Union_Restriction);
- Set_Etype (Result, Standard_Boolean);
- return Result;
-
- else
- Insert_Action (Lhs,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Unchecked_Union_Restriction));
- return New_Occurrence_Of (Standard_True, Loc);
- end if;
- end if;
-
-- Generates the following code: (assuming that Typ has one Discr and
-- component C2 is also a record)
return Find_Final_List (Owner);
end Get_Allocator_Final_List;
+ ---------------------------------
+ -- Has_Inferable_Discriminants --
+ ---------------------------------
+
+ function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
+
+ function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
+ -- Determines whether the left-most prefix of a selected component is a
+ -- formal parameter in a subprogram. Assumes N is a selected component.
+
+ --------------------------------
+ -- Prefix_Is_Formal_Parameter --
+ --------------------------------
+
+ function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
+ Sel_Comp : Node_Id := N;
+
+ begin
+ -- Move to the left-most prefix by climbing up the tree
+
+ while Present (Parent (Sel_Comp))
+ and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
+ loop
+ Sel_Comp := Parent (Sel_Comp);
+ end loop;
+
+ return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
+ end Prefix_Is_Formal_Parameter;
+
+ -- Start of processing for Has_Inferable_Discriminants
+
+ begin
+ -- For identifiers and indexed components, it is sufficent to have a
+ -- constrained Unchecked_Union nominal subtype.
+
+ if Nkind (N) = N_Identifier
+ or else
+ Nkind (N) = N_Indexed_Component
+ then
+ return Is_Unchecked_Union (Base_Type (Etype (N)))
+ and then
+ Is_Constrained (Etype (N));
+
+ -- For selected components, the subtype of the selector must be a
+ -- constrained Unchecked_Union. If the component is subject to a
+ -- per-object constraint, then the enclosing object must have inferable
+ -- discriminants.
+
+ elsif Nkind (N) = N_Selected_Component then
+ if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
+
+ -- A small hack. If we have a per-object constrained selected
+ -- component of a formal parameter, return True since we do not
+ -- know the actual parameter association yet.
+
+ if Prefix_Is_Formal_Parameter (N) then
+ return True;
+ end if;
+
+ -- Otherwise, check the enclosing object and the selector
+
+ return Has_Inferable_Discriminants (Prefix (N))
+ and then
+ Has_Inferable_Discriminants (Selector_Name (N));
+ end if;
+
+ -- The call to Has_Inferable_Discriminants will determine whether
+ -- the selector has a constrained Unchecked_Union nominal type.
+
+ return Has_Inferable_Discriminants (Selector_Name (N));
+
+ -- A qualified expression has inferable discriminants if its subtype
+ -- mark is a constrained Unchecked_Union subtype.
+
+ elsif Nkind (N) = N_Qualified_Expression then
+ return Is_Unchecked_Union (Subtype_Mark (N))
+ and then
+ Is_Constrained (Subtype_Mark (N));
+
+ end if;
+
+ return False;
+ end Has_Inferable_Discriminants;
+
-------------------------------
-- Insert_Dereference_Action --
-------------------------------
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sem; use Sem;
+with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
-- the type may be private and resolution by identifier alone would
-- fail.
- function Make_Component_List_Assign (CL : Node_Id) return List_Id;
+ function Make_Component_List_Assign
+ (CL : Node_Id;
+ U_U : Boolean := False) return List_Id;
-- Returns a sequence of statements to assign the components that
- -- are referenced in the given component list.
-
- function Make_Field_Assign (C : Entity_Id) return Node_Id;
- -- Given C, the entity for a discriminant or component, build
- -- an assignment for the corresponding field values.
+ -- are referenced in the given component list. The flag U_U is
+ -- used to force the usage of the inferred value of the variant
+ -- part expression as the switch for the generated case statement.
+
+ function Make_Field_Assign
+ (C : Entity_Id;
+ U_U : Boolean := False) return Node_Id;
+ -- Given C, the entity for a discriminant or component, build an
+ -- assignment for the corresponding field values. The flag U_U
+ -- signals the presence of an Unchecked_Union and forces the usage
+ -- of the inferred discriminant value of C as the right hand side
+ -- of the assignment.
function Make_Field_Assigns (CI : List_Id) return List_Id;
-- Given CI, a component items list, construct series of statements
-- Make_Component_List_Assign --
--------------------------------
- function Make_Component_List_Assign (CL : Node_Id) return List_Id is
+ function Make_Component_List_Assign
+ (CL : Node_Id;
+ U_U : Boolean := False) return List_Id
+ is
CI : constant List_Id := Component_Items (CL);
VP : constant Node_Id := Variant_Part (CL);
- Result : List_Id;
Alts : List_Id;
- V : Node_Id;
DC : Node_Id;
DCH : List_Id;
+ Expr : Node_Id;
+ Result : List_Id;
+ V : Node_Id;
begin
Result := Make_Field_Assigns (CI);
Next_Non_Pragma (V);
end loop;
+ -- If we have an Unchecked_Union, use the value of the inferred
+ -- discriminant of the variant part expression as the switch
+ -- for the case statement. The case statement may later be
+ -- folded.
+
+ if U_U then
+ Expr :=
+ New_Copy (Get_Discriminant_Value (
+ Entity (Name (VP)),
+ Etype (Rhs),
+ Discriminant_Constraint (Etype (Rhs))));
+ else
+ Expr :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Rhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Name (VP))));
+ end if;
+
Append_To (Result,
Make_Case_Statement (Loc,
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Name (VP)))),
+ Expression => Expr,
Alternatives => Alts));
-
end if;
return Result;
-- Make_Field_Assign --
-----------------------
- function Make_Field_Assign (C : Entity_Id) return Node_Id is
- A : Node_Id;
+ function Make_Field_Assign
+ (C : Entity_Id;
+ U_U : Boolean := False) return Node_Id
+ is
+ A : Node_Id;
+ Expr : Node_Id;
begin
+ -- In the case of an Unchecked_Union, use the discriminant
+ -- constraint value as on the right hand side of the assignment.
+
+ if U_U then
+ Expr :=
+ New_Copy (Get_Discriminant_Value (C,
+ Etype (Rhs),
+ Discriminant_Constraint (Etype (Rhs))));
+ else
+ Expr :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Rhs),
+ Selector_Name => New_Occurrence_Of (C, Loc));
+ end if;
+
A :=
Make_Assignment_Statement (Loc,
Name =>
Prefix => Duplicate_Subexpr (Lhs),
Selector_Name =>
New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
- Selector_Name => New_Occurrence_Of (C, Loc)));
+ Expression => Expr);
-- Set Assignment_OK, so discriminants can be assigned
begin
Item := First (CI);
Result := New_List;
-
while Present (Item) loop
if Nkind (Item) = N_Component_Declaration then
Append_To
if Has_Discriminants (L_Typ) then
F := First_Discriminant (R_Typ);
while Present (F) loop
- Insert_Action (N, Make_Field_Assign (F));
+
+ if Is_Unchecked_Union (Base_Type (R_Typ)) then
+ Insert_Action (N, Make_Field_Assign (F, True));
+ else
+ Insert_Action (N, Make_Field_Assign (F));
+ end if;
+
Next_Discriminant (F);
end loop;
end if;
if Nkind (RDef) = N_Record_Definition
and then Present (Component_List (RDef))
then
- Insert_Actions
- (N, Make_Component_List_Assign (Component_List (RDef)));
+
+ if Is_Unchecked_Union (R_Typ) then
+ Insert_Actions (N,
+ Make_Component_List_Assign (Component_List (RDef), True));
+ else
+ Insert_Actions
+ (N, Make_Component_List_Assign (Component_List (RDef)));
+ end if;
Rewrite (N, Make_Null_Statement (Loc));
end if;
Res : List_Id;
Tag_Tmp : Entity_Id;
- Original_Size, Range_Type, Opaque_Type : Entity_Id;
begin
Res := New_List;
Tag_Tmp := Empty;
end if;
- -- We really need a comment here ???
-
- if Ctrl_Act then
-
- -- subtype G is Storage_Offset range 1 .. Expr'Size
-
- Original_Size :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('S'));
-
- Append_To (Res,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Original_Size,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (
- RTE (RE_Storage_Offset), Loc),
- Expression =>
- Make_Op_Divide (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- Duplicate_Subexpr_No_Checks (L),
- Attribute_Name => Name_Size),
- Right_Opnd => Make_Integer_Literal (Loc,
- Intval => System_Storage_Unit))));
-
- Range_Type :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('G'));
+ -- Processing for controlled types and types with controlled components
- Append_To (Res,
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Range_Type,
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Storage_Offset), Loc),
- Constraint => Make_Range_Constraint (Loc,
- Range_Expression =>
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => New_Occurrence_Of (
- Original_Size, Loc))))));
-
- -- subtype S is Storage_Array (G)
+ -- Variables of such types contain pointers used to chain them in
+ -- finalization lists, in addition to user data. These pointers are
+ -- specific to each object of the type, not to the value being assigned.
+ -- Thus they need to be left intact during the assignment. We achieve
+ -- this by constructing a Storage_Array subtype, and by overlaying
+ -- objects of this type on the source and target of the assignment.
+ -- The assignment is then rewritten to assignments of slices of these
+ -- arrays, copying the user data, and leaving the pointers untouched.
- Append_To (Res,
- Make_Subtype_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('S')),
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Storage_Array), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints =>
- New_List (New_Reference_To (Range_Type, Loc))))));
-
- -- type A is access S
-
- Opaque_Type := Make_Defining_Identifier (Loc,
- New_Internal_Name ('A'));
- Append_To (Res,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Opaque_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (
- Defining_Identifier (Last (Res)), Loc))));
-
- -- Give a label name to this declare block, and add comments here???
-
- declare
+ if Ctrl_Act then
+ Controlled_Actions : declare
Prev_Ref : Node_Id;
+ -- A reference to the Prev component of the record controller
First_After_Root : Node_Id := Empty;
-- Index of first byte to be copied (used to skip
-- Index of first byte to be copied after outermost record
-- controller data.
+ Expr, Source_Size : Node_Id;
+ -- Used for computation of the size of the data to be copied
+
+ Range_Type : Entity_Id;
+ Opaque_Type : Entity_Id;
+
function Build_Slice
- (Rec : Entity_Id;
- Lo, Hi : Node_Id) return Node_Id;
- -- Function specs must have comments, saying what all the
- -- parameters are and what the function does ???
+ (Rec : Entity_Id;
+ Lo : Node_Id;
+ Hi : Node_Id) return Node_Id;
+ -- Build and return a slice of an array of type S overlaid
+ -- on object Rec, with bounds specified by Lo and Hi. If either
+ -- bound is empty, a default of S'First (respectively S'Last)
+ -- is used.
-----------------
-- Build_Slice --
-----------------
function Build_Slice
- (Rec : Node_Id;
- Lo, Hi : Node_Id) return Node_Id
+ (Rec : Node_Id;
+ Lo : Node_Id;
+ Hi : Node_Id) return Node_Id
is
- Lo_Bound, Hi_Bound : Node_Id;
+ Lo_Bound : Node_Id;
+ Hi_Bound : Node_Id;
Opaque : constant Node_Id :=
Unchecked_Convert_To (Opaque_Type,
Make_Attribute_Reference (Loc,
Prefix => Rec,
Attribute_Name => Name_Address));
- -- Comment required, what is this???
+ -- Access value designating an opaque storage array of
+ -- type S overlaid on record Rec.
begin
- -- Comments required in this body ???
+ -- Compute slice bounds using S'First (1) and S'Last
+ -- as default values when not specified by the caller.
if No (Lo) then
Lo_Bound := Make_Integer_Literal (Loc, 1);
Lo_Bound, Hi_Bound));
end Build_Slice;
- -- Start of processing for ??? (name of block)
+ -- Start of processing for Controlled_Actions
begin
+ -- Create a constrained subtype of Storage_Array whose size
+ -- corresponds to the value being assigned.
+
+ -- subtype G is Storage_Offset range
+ -- 1 .. (Expr'Size + Storage_Unit - 1) / Storage_Unit
+
+ Expr := Duplicate_Subexpr_No_Checks (Expression (N));
+
+ if Nkind (Expr) = N_Qualified_Expression then
+ Expr := Expression (Expr);
+ end if;
+
+ Source_Size :=
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Expr,
+ Attribute_Name =>
+ Name_Size),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ System_Storage_Unit - 1));
+
+ -- If Expr is a type conversion, standard Ada does not allow
+ -- 'Size to be taken on it, but Gigi can handle this case,
+ -- and thus we can determine the amount of data to be copied.
+ -- The appropriate circuitry is enabled only for conversions
+ -- that do not Come_From_Source.
+
+ Set_Comes_From_Source (Prefix (Left_Opnd (Source_Size)), False);
+
+ Source_Size :=
+ Make_Op_Divide (Loc,
+ Left_Opnd => Source_Size,
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Intval => System_Storage_Unit));
+
+ Range_Type :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('G'));
+
+ Append_To (Res,
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Range_Type,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Storage_Offset), Loc),
+ Constraint => Make_Range_Constraint (Loc,
+ Range_Expression =>
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Source_Size)))));
+
+ -- subtype S is Storage_Array (G)
+
+ Append_To (Res,
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('S')),
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Reference_To (RTE (RE_Storage_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints =>
+ New_List (New_Reference_To (Range_Type, Loc))))));
+
+ -- type A is access S
+
+ Opaque_Type :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('A'));
+
+ Append_To (Res,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Opaque_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (
+ Defining_Identifier (Last (Res)), Loc))));
+
+ -- Generate appropriate slice assignments
+
First_After_Root := Make_Integer_Literal (Loc, 1);
- -- Comment ???
+ -- For the case of a controlled object, skip the
+ -- Root_Controlled part.
if Is_Controlled (T) then
First_After_Root :=
Make_Integer_Literal (Loc, System_Storage_Unit)));
end if;
- if Has_Controlled_Component (T) then
-
- -- The record controller Prev and Next pointers must be left
- -- intact in the target object, not copied. Compute the bounds
- -- of the hole to be skipped in copying the objecct.
+ -- For the case of a record with controlled components, skip
+ -- the Prev and Next components of the record controller.
+ -- These components constitute a 'hole' in the middle of the
+ -- data to be copied.
+ if Has_Controlled_Component (T) then
Prev_Ref :=
Make_Selected_Component (Loc,
Prefix =>
New_Reference_To (Controller_Component (T), Loc)),
Selector_Name => Make_Identifier (Loc, Name_Prev));
- -- Last index before hole
+ -- Last index before hole: determined by position of
+ -- the _Controller.Prev component.
Last_Before_Hole :=
Make_Defining_Identifier (Loc,
Prefix => New_Copy_Tree (Prefix (Prev_Ref)),
Attribute_Name => Name_Position))));
- -- Hole length
+ -- Hole length: size of the Prev and Next components
Hole_Length :=
Make_Op_Multiply (Loc,
- Make_Integer_Literal (Loc, Uint_2),
+ Left_Opnd => Make_Integer_Literal (Loc, Uint_2),
+ Right_Opnd =>
Make_Op_Divide (Loc,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Copy_Tree (Prev_Ref),
- Attribute_Name =>
- Name_Size),
- Make_Integer_Literal (Loc, System_Storage_Unit)));
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Prev_Ref),
+ Attribute_Name => Name_Size),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Intval => System_Storage_Unit)));
-- First index after hole
Constant_Present => True,
Expression =>
Make_Op_Add (Loc,
- Make_Op_Add (Loc,
- New_Occurrence_Of (Last_Before_Hole, Loc),
- Hole_Length),
- Make_Integer_Literal (Loc, 1))));
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Last_Before_Hole, Loc),
+ Right_Opnd => Hole_Length),
+ Right_Opnd => Make_Integer_Literal (Loc, 1))));
Last_Before_Hole := New_Occurrence_Of (Last_Before_Hole, Loc);
First_After_Hole := New_Occurrence_Of (First_After_Hole, Loc);
end if;
- -- More comments needed everywhere ???
+ -- Assign the first slice (possibly skipping Root_Controlled,
+ -- up to the beginning of the record controller if present,
+ -- up to the end of the object if not).
Append_To (Res, Make_Assignment_Statement (Loc,
- Name => Build_Slice (Duplicate_Subexpr_No_Checks (L),
- First_After_Root,
- Last_Before_Hole),
-
- Expression => Build_Slice (Expression (N),
- First_After_Root,
- New_Copy_Tree (Last_Before_Hole))));
+ Name => Build_Slice (
+ Rec => Duplicate_Subexpr_No_Checks (L),
+ Lo => First_After_Root,
+ Hi => Last_Before_Hole),
+ Expression => Build_Slice (
+ Rec => Expression (N),
+ Lo => First_After_Root,
+ Hi => New_Copy_Tree (Last_Before_Hole))));
if Present (First_After_Hole) then
- Remove_Side_Effects (Expression (N));
+
+ -- If a record controller is present, copy the second slice,
+ -- from right after the _Controller.Next component up to the
+ -- end of the object.
+
Append_To (Res, Make_Assignment_Statement (Loc,
- Name => Build_Slice (Duplicate_Subexpr_No_Checks (L),
- First_After_Hole,
- Empty),
- Expression => Build_Slice (New_Copy_Tree (Expression (N)),
- New_Copy_Tree (First_After_Hole),
- Empty)));
+ Name => Build_Slice (
+ Rec => Duplicate_Subexpr_No_Checks (L),
+ Lo => First_After_Hole,
+ Hi => Empty),
+ Expression => Build_Slice (
+ Rec => Duplicate_Subexpr_No_Checks (Expression (N)),
+ Lo => New_Copy_Tree (First_After_Hole),
+ Hi => Empty)));
end if;
- end;
+ end Controlled_Actions;
else
Append_To (Res, Relocate_Node (N));
end if;
- -- Restore the Tag
+ -- Restore the tag
if Save_Tag then
Append_To (Res,
New_Occurrence_Of (Standard_True, Loc),
Extra_Constrained (Formal));
+ -- Do not produce extra actuals for Unchecked_Union parameters.
+ -- Jump directly to the end of the loop.
+
+ elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then
+ goto Skip_Extra_Actual_Generation;
+
else
-- If the actual is a type conversion, then the constrained
-- test applies to the actual, not the target type.
Reason => PE_Illegal_RACW_E_4_18))));
end if;
+ -- This label is required when skipping extra actual generation for
+ -- Unchecked_Union parameters.
+
+ <<Skip_Extra_Actual_Generation>>
+
Next_Actual (Actual);
Next_Formal (Formal);
end loop;
------------------------------------
procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
- SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+ SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+ Target : Node_Id;
begin
+ -- If the node to be wrapped is the triggering alternative of an
+ -- asynchronous select, it is not part of a statement list. The
+ -- actions must be inserted before the Select itself, which is
+ -- part of some list of statements.
+
+ if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative then
+ Target := Parent (Parent (Node_To_Be_Wrapped));
+ else
+ Target := N;
+ end if;
+
if Present (SE.Actions_To_Be_Wrapped_Before) then
- Insert_List_Before (N, SE.Actions_To_Be_Wrapped_Before);
+ Insert_List_Before (Target, SE.Actions_To_Be_Wrapped_Before);
SE.Actions_To_Be_Wrapped_Before := No_List;
end if;
if Present (SE.Actions_To_Be_Wrapped_After) then
- Insert_List_After (N, SE.Actions_To_Be_Wrapped_After);
+ Insert_List_After (Target, SE.Actions_To_Be_Wrapped_After);
SE.Actions_To_Be_Wrapped_After := No_List;
end if;
end Insert_Actions_In_Scope_Around;
Ensure_Type_Is_SA (Etype (E));
-- Reset True_Constant flag, since something strange is going on
- -- with the scoping here, and our simple value traceing may not
+ -- with the scoping here, and our simple value tracing may not
-- be sufficient for this indication to be reliable. We kill the
-- Constant_Value indication for the same reason.
with GNAT.Sockets.Linker_Options;
pragma Warnings (Off, GNAT.Sockets.Linker_Options);
--- Need to include pragma Linker_Options which is platform dependent.
+-- Need to include pragma Linker_Options which is platform dependent
with System; use System;
--------------------
procedure Abort_Selector (Selector : Selector_Type) is
- Buf : Character;
+ Buf : aliased Character := ASCII.NUL;
Discard : C.int;
- pragma Warnings (Off, Discard);
+ pragma Unreferenced (Discard);
begin
-- Send an empty array to unblock C select system call
begin
return Item.Last /= No_Socket
and then Socket <= Item.Last
- and then Is_Socket_In_Set (Item.Set, C.int (Socket));
+ and then Is_Socket_In_Set (Item.Set, C.int (Socket)) /= 0;
end Is_Set;
-------------------
use type C.unsigned_short;
begin
- pragma Warnings (Off);
-
-- Big-endian case. No conversion needed. On these platforms,
-- htons() defaults to a null procedure.
+ pragma Warnings (Off);
+ -- Since the test can generate "always True/False" warning
+
if Default_Bit_Order = High_Order_First then
return S;
+ pragma Warnings (On);
+
-- Little-endian case. We must swap the high and low bytes of this
-- short to make the port number network compliant.
else
return (S / 256) + (S mod 256) * 256;
end if;
-
- pragma Warnings (On);
end Short_To_Network;
---------------------
-- is not watching for it.
if WFSC /= No_Fd_Set
- and then Is_Socket_In_Set (WFSC, S)
+ and then (Is_Socket_In_Set (WFSC, S) /= 0)
then
Insert_Socket_In_Set (WFS, S);
end if;
function Is_Socket_In_Set
(Set : Fd_Set_Access;
- Socket : C.int) return Boolean;
- -- Check whether Socket is in the socket set
+ Socket : C.int) return C.int;
+ -- Check whether Socket is in the socket set, return a non-zero
+ -- value if it is, zero if it is not.
procedure Last_Socket_In_Set
(Set : Fd_Set_Access;
R : Boolean;
begin
Task_Lock.Lock;
- R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
+ R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
Task_Lock.Unlock;
return R;
end Non_Blocking_Socket;
function Is_Socket_In_Set
(Set : Fd_Set_Access;
- Socket : C.int)
- return Boolean;
- -- Check whether Socket is in the socket set.
+ Socket : C.int) return C.int;
+ -- Check whether Socket is in the socket set, return a non-zero
+ -- value if it is, zero if it is not.
procedure Last_Socket_In_Set
(Set : Fd_Set_Access;
begin
Task_Lock.Lock;
- R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
+ R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
Task_Lock.Unlock;
return R;
end Non_Blocking_Socket;
function Is_Socket_In_Set
(Set : Fd_Set_Access;
- Socket : C.int)
- return Boolean;
- -- Check whether Socket is in the socket set
+ Socket : C.int) return C.int;
+ -- Check whether Socket is in the socket set, return a non-zero
+ -- value if it is, zero if it is not.
procedure Last_Socket_In_Set
(Set : Fd_Set_Access;
R : Boolean;
begin
Task_Lock.Lock;
- R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
+ R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
Task_Lock.Unlock;
return R;
end Non_Blocking_Socket;
function Is_Socket_In_Set
(Set : Fd_Set_Access;
- Socket : C.int) return Boolean;
- -- Check whether Socket is in the socket set
+ Socket : C.int) return C.int;
+ -- Check whether Socket is in the socket set, return a non-zero
+ -- value if it is, zero if it is not.
procedure Last_Socket_In_Set
(Set : Fd_Set_Access;
@c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
@setfilename gnat_rm.info
+
+@set FSFEDITION
+
@settitle GNAT Reference Manual
+
@setchapternewpage odd
@syncodeindex fn cp
* Specialized Needs Annexes::
* Implementation of Specific Ada Features::
* Project File Reference::
+* Obsolescent Features::
* GNU Free Documentation License::
* Index::
* Pragma Passive::
* Pragma Polling::
* Pragma Profile (Ravenscar)::
+* Pragma Profile (Restricted)::
* Pragma Propagate_Exceptions::
* Pragma Psect_Object::
* Pragma Pure_Function::
-* Pragma Restricted_Run_Time::
* Pragma Restriction_Warnings::
* Pragma Source_File_Name::
* Pragma Source_File_Name_Project::
Project File Reference
+Obsolescent Features
+
GNU Free Documentation License
Index
@node About This Guide
@unnumbered About This Guide
+@ifclear PROEDITION
@noindent
This manual contains useful information in writing programs using the
GNAT compiler. It includes information on implementation dependent
characteristics of GNAT, including all the information required by Annex
M of the standard.
+@end ifclear
+
+@ifset PROEDITION
+@noindent
+This manual contains useful information in writing programs using the
+GNAT Pro compiler. It includes information on implementation dependent
+characteristics of GNAT Pro, including all the information required by Annex
+M of the standard.
+@end ifset
Ada 95 is designed to be highly portable.
In general, a program will have the same effect even when compiled by
isolate and clearly document any sections of your program that make use
of these features in a non-portable manner.
+@ifset PROEDITION
+For ease of exposition, ``GNAT Pro'' will be referred to simply as
+``GNAT'' in the remainder of this document.
+@end ifset
+
@menu
* What This Reference Manual Contains::
* Conventions::
@ref{Project File Reference}, presents the syntax and semantics
of project files.
+@item
+@ref{Obsolescent Features} documents implementation dependent features,
+including pragmas and attributes, which are considered obsolescent, since
+there are other preferred ways of achieving the same results. These
+obsolescent forms are retained for backwards compatibilty.
+
@end itemize
@cindex Ada 95 ISO/ANSI Standard
* Pragma Passive::
* Pragma Polling::
* Pragma Profile (Ravenscar)::
+* Pragma Profile (Restricted)::
* Pragma Propagate_Exceptions::
* Pragma Psect_Object::
* Pragma Pure_Function::
-* Pragma Restricted_Run_Time::
* Pragma Restriction_Warnings::
* Pragma Source_File_Name::
* Pragma Source_File_Name_Project::
respectively.
The above set is a superset of the restrictions provided by pragma
-@code{Restricted_Run_Time}, it includes six additional restrictions
+@code{Profile (Restricted)}, it includes six additional restrictions
(@code{Simple_Barriers}, @code{No_Select_Statements},
@code{No_Calendar}, @code{No_Implicit_Heap_Allocations},
@code{No_Relative_Delay} and @code{No_Task_Termination}). This means
that pragma @code{Profile (Ravenscar)}, like the pragma
-@code{Restricted_Run_Time}, automatically causes the use of a simplified,
+@code{Profile (Restricted)},
+automatically causes the use of a simplified,
more efficient version of the tasking run-time system.
+@node Pragma Profile (Restricted)
+@unnumberedsec Pragma Profile (Restricted)
+@findex Restricted Run Time
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Profile (Restricted);
+@end smallexample
+
+@noindent
+A configuration pragma that establishes the following set of restrictions:
+
+@itemize @bullet
+@item No_Abort_Statements
+@item No_Entry_Queue
+@item No_Task_Hierarchy
+@item No_Task_Allocators
+@item No_Dynamic_Priorities
+@item No_Terminate_Alternatives
+@item No_Dynamic_Attachment
+@item No_Protected_Type_Allocators
+@item No_Local_Protected_Objects
+@item No_Requeue_Statements
+@item No_Task_Attributes_Package
+@item Max_Asynchronous_Select_Nesting = 0
+@item Max_Task_Entries = 0
+@item Max_Protected_Entries = 1
+@item Max_Select_Alternatives = 0
+@end itemize
+
+@noindent
+This set of restrictions causes the automatic selection of a simplified
+version of the run time that provides improved performance for the
+limited set of tasking functionality permitted by this set of restrictions.
+
@node Pragma Propagate_Exceptions
@unnumberedsec Pragma Propagate_Exceptions
@findex Propagate_Exceptions
disambiguate cases of overloading where some but not all functions
in a set of overloaded functions are to be designated as pure.
-@node Pragma Restricted_Run_Time
-@unnumberedsec Pragma Restricted_Run_Time
-@findex Restricted_Run_Time
-@noindent
-Syntax:
-
-@smallexample @c ada
-pragma Restricted_Run_Time;
-@end smallexample
-
-@noindent
-A configuration pragma that establishes the following set of restrictions:
-
-@itemize @bullet
-@item No_Abort_Statements
-@item No_Entry_Queue
-@item No_Task_Hierarchy
-@item No_Task_Allocators
-@item No_Dynamic_Priorities
-@item No_Terminate_Alternatives
-@item No_Dynamic_Attachment
-@item No_Protected_Type_Allocators
-@item No_Local_Protected_Objects
-@item No_Requeue_Statements
-@item No_Task_Attributes_Package
-@item Max_Asynchronous_Select_Nesting = 0
-@item Max_Task_Entries = 0
-@item Max_Protected_Entries = 1
-@item Max_Select_Alternatives = 0
-@end itemize
-
-@noindent
-This set of restrictions causes the automatic selection of a simplified
-version of the run time that provides improved performance for the
-limited set of tasking functionality permitted by this set of restrictions.
-
@node Pragma Restriction_Warnings
@unnumberedsec Pragma Restriction_Warnings
@findex Restriction_Warnings
GNAT currently takes advantage of these restrictions by providing an optimized
run time when the Ravenscar profile and the GNAT restricted run time set
of restrictions are specified. See pragma @code{Profile (Ravenscar)} and
-pragma @code{Restricted_Run_Time} for more details.
+pragma @code{Profile (Restricted)} for more details.
@cindex Time, monotonic
@unnumberedsec D.8(47-49): Monotonic Time
This restriction ensures that the generated code does not contain any
implicit conditionals, either by modifying the generated code where possible,
or by rejecting any construct that would otherwise generate an implicit
-conditional.
+conditional. Note that this check does not include run time constraint
+checks, which on some targets may generate implicit conditionals as
+well. To control the latter, constraint checks can be suppressed in the
+normal manner.
@item No_Implicit_Dynamic_Code
@findex No_Implicit_Dynamic_Code
attributes and variables in the project are then used to establish the
environment in which the gnat tool will execute.
+@node Obsolescent Features
+@chapter Obsolescent Features
+
+@noindent
+This chapter describes features that are provided by GNAT, but are
+considered obsolescent since there are preferred ways of achieving
+the same effect. These features are provided solely for historical
+compatibility purposes.
+
+@menu
+* pragma No_Run_Time::
+* pragma Ravenscar::
+* pragma Restricted_Run_Time::
+@end menu
+
+@node pragma No_Run_Time
+@section pragma No_Run_Time
+
+The pragma @code{No_Run_Time} is used to achieve an affect similar
+to the use of the "Zero Foot Print" configurable run time, but without
+requiring a specially configured run time. The result of using this
+pragma, which must be used for all units in a partition, is to restrict
+the use of any language features requiring run-time support code. The
+preferred usage is to use an appropriately configured run-time that
+includes just those features that are to be made accessible.
+
+@node pragma Ravenscar
+@section pragma Ravenscar
+
+The pragma @code{Ravenscar} has exactly the same effect as pragma
+@code{Profile (Ravenscar)}. The latter usage is preferred since it
+is part of the new Ada 2005 standard.
+
+@node pragma Restricted_Run_Time
+@section pragma Restricted_Run_Time
+
+The pragma @code{Restricted_Run_Time} has exactly the same effect as
+pragma @code{Profile (Restricted)}. The latter usage is
+preferred since the Ada 2005 pragma @code{Profile} is intended for
+this kind of implementation dependent addition.
+
@include fdl.texi
@c GNU Free Documentation License
@setfilename gnat_ugn_unw.info
@end ifset
+@set FSFEDITION
+@set EDITION GNAT
+
+@ifset unw
+@set PLATFORM Unix and Windows
+@set FILE gnat_ugn_unw
+@end ifset
+
@ifset vms
-@settitle GNAT User's Guide for Native Platforms / OpenVMS Alpha
-@dircategory GNU Ada tools
-@direntry
-* GNAT User's Guide (gnat_ugn_vms) for Native Platforms / OpenVMS Alpha
-@end direntry
+@set PLATFORM OpenVMS Alpha
+@set FILE gnat_ugn_vms
@end ifset
-@ifset unw
-@settitle GNAT User's Guide for Native Platforms / Unix and Windows
+
+
+@settitle @value{EDITION} User's Guide for Native Platforms / @value{PLATFORM}
+@dircategory GNU Ada tools
@direntry
-* GNAT User's Guide (gnat_ugn_unw) for Native Platforms / Unix and Windows
+* @value{EDITION} User's Guide (@value{FILE}) for Native Platforms / @value{PLATFORM}
@end direntry
-@end ifset
@include gcc-common.texi
or any later version published by the Free Software Foundation;
with the Invariant Sections being ``GNU Free Documentation License'', with the
Front-Cover Texts being
-@ifset vms
-``GNAT User's Guide for Native Platforms / OpenVMS Alpha'',
-@end ifset
-@ifset unw
-``GNAT User's Guide for Native Platforms / Unix and Windows'',
-@end ifset
+``GNAT User's Guide for Native Platforms / @value{PLATFORM}'',
and with no Back-Cover Texts.
A copy of the license is included in the section entitled
``GNU Free Documentation License''.
@titlepage
-@title GNAT User's Guide
+@title @value{EDITION} User's Guide
@center @titlefont{for Native Platforms}
@sp 1
@flushright
-@ifset unw
-@titlefont{@i{Unix and Windows}}
-@end ifset
-@ifset vms
-@titlefont{@i{OpenVMS Alpha}}
-@end ifset
+@titlefont{@i{@value{PLATFORM}}}
@end flushright
@sp 2
@ifnottex
@node Top, About This Guide, (dir), (dir)
-@top GNAT User's Guide
-
-@ifset vms
-@noindent
-GNAT User's Guide for Native Platforms / OpenVMS Alpha
-@end ifset
+@top @value{EDITION} User's Guide
-@ifset unw
@noindent
-GNAT User's Guide for Native Platforms / Unix and Windows
-@end ifset
+@value{EDITION} User's Guide for Native Platforms / @value{PLATFORM}
@noindent
GNAT, The GNU Ada 95 Compiler@*
@noindent
@ifset vms
-This guide describes the use of of GNAT, a full language compiler for the Ada
+This guide describes the use of of @value{EDITION},
+a full language compiler for the Ada
95 programming language, implemented on HP OpenVMS Alpha platforms.
@end ifset
@ifclear vms
-This guide describes the use of GNAT, a compiler and software development
+This guide describes the use of @value{EDITION},
+a compiler and software development
toolset for the full Ada 95 programming language.
@end ifclear
It describes the features of the compiler and tools, and details
how to use them to build Ada 95 applications.
+@ifset PROEDITION
+For ease of exposition, ``GNAT Pro'' will be referred to simply as
+``GNAT'' in the remainder of this document.
+@end ifset
+
+
+
@menu
* What This Guide Contains::
* What You Should Know before Reading This Guide::
* Introduction to Dynamic Link Libraries (DLLs)::
* Using DLLs with GNAT::
* Building DLLs with GNAT::
+* Building DLLs with GNAT Project files::
+* Building DLLs with gnatdll::
* GNAT and Windows Resources::
* Debugging a DLL::
* GNAT and COM/DCOM Objects::
To illustrate the remainder of this section, suppose that an application
wants to use the services of a DLL @file{API.dll}. To use the services
-provided by @file{API.dll} you must statically link against an import
-library which contains a jump table with an entry for each routine and
-variable exported by the DLL. In the Microsoft world this import library is
-called @file{API.lib}. When using GNAT this import library is called either
-@file{libAPI.a} or @file{libapi.a} (names are case insensitive).
-
-After you have statically linked your application with the import library
+provided by @file{API.dll} you must statically link against the DLL or
+an import library which contains a jump table with an entry for each
+routine and variable exported by the DLL. In the Microsoft world this
+import library is called @file{API.lib}. When using GNAT this import
+library is called either @file{libAPI.a} or @file{libapi.a} (names are
+case insensitive).
+
+After you have linked your application with the DLL or the import library
and you run your application, here is what happens:
@enumerate
@end itemize
@item
-The entries in the @file{libAPI.a} or @file{API.lib} jump table which is
-part of your application are initialized with the addresses of the routines
-and variables in @file{API.dll}.
+The entries in the jump table (from the import library @file{libAPI.a}
+or @file{API.lib} or automatically created when linking against a DLL)
+which is part of your application are initialized with the addresses
+of the routines and variables in @file{API.dll}.
@item
If present in @file{API.dll}, routines @code{DllMain} or
As a side note, an interesting difference between Microsoft DLLs and
Unix shared libraries, is the fact that on most Unix systems all public
routines are exported by default in a Unix shared library, while under
-Windows the exported routines must be listed explicitly in a definition
-file (@pxref{The Definition File}).
+Windows it is possible (but not required) to list exported routines in
+a definition file (@pxref{The Definition File}).
@node Using DLLs with GNAT
@section Using DLLs with GNAT
mentioned an import library is a statically linked library containing the
import table which will be filled at load time to point to the actual
@file{API.dll} routines. Sometimes you don't have an import library for the
-DLL you want to use. The following sections will explain how to build one.
+DLL you want to use. The following sections will explain how to build
+one. Note that this is optional.
@item
The actual DLL, @file{API.dll}.
@noindent
If a Microsoft-style import library @file{API.lib} or a GNAT-style
import library @file{libAPI.a} is available with @file{API.dll} you
-can skip this section. Otherwise read on.
+can skip this section. You can also skip this section if
+@file{API.dll} is built with GNU tools as in this case it is possible
+to link directly against the DLL. Otherwise read on.
@node The Definition File
@subsubsection The Definition File
@section Building DLLs with GNAT
@cindex DLLs, building
+@noindent
+This section explain how to build DLLs using the GNAT built-in DLL
+support. With the following procedure it is straight forward to build
+and use DLLs with GNAT.
+
+@enumerate
+
+@item building object files
+
+The first step is to build all objects files that are to be included
+into the DLL. This is done by using the standard @code{gnatmake} tool.
+
+@item building the DLL
+
+To build the DLL you must use @code{gcc}'s @code{-shared}
+option. It is quite simple to use this method:
+
+@smallexample
+$ gcc -shared -o api.dll obj1.o obj2.o ...
+@end smallexample
+
+It is important to note that in this case all symbols found in the
+object files are automatically exported. It is possible to restrict
+the set of symbols to export by passing to @code{gcc} a definition
+file, @pxref{The Definition File}. For example:
+
+@smallexample
+$ gcc -shared -o api.dll api.def obj1.o obj2.o ...
+@end smallexample
+
+If you use a definition file you must export the elaboration procedures
+for every package that required one. Elaboration procedures are named
+using the package name followed by "_E".
+
+@item preparing DLL to be used
+
+For the DLL to be used by client programs the bodies must be hidden
+from it and the .ali set with read-only attribute. This is very important
+otherwise GNAT will recompile all packages and will not actually use
+the code in the DLL. For example:
+
+@smallexample
+$ mkdir apilib
+$ copy *.ads *.ali api.dll apilib
+$ attrib +R apilib\*.ali
+@end smallexample
+
+@end enumerate
+
+At this point it is possible to use the DLL by directly linking
+against it. Note that you must use the GNAT shared runtime when using
+GNAT shared libraries. This is achieved by using @code{-shared} binder's
+option.
+
+@smallexample
+$ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI
+@end smallexample
+
+@node Building DLLs with GNAT Project files
+@section Building DLLs with GNAT Project files
+@cindex DLLs, building
+
+@noindent
+There is nothing specific to Windows in this area. @pxref{Library Projects}.
+
+@node Building DLLs with gnatdll
+@section Building DLLs with gnatdll
+@cindex DLLs, building
+
@menu
* Limitations When Using Ada DLLs from Ada::
* Exporting Ada Entities::
@end menu
@noindent
-This section explains how to build DLLs containing Ada code. These DLLs
-will be referred to as Ada DLLs in the remainder of this section.
+Note that it is prefered to use the built-in GNAT DLL support
+(@pxref{Building DLLs with GNAT}) or GNAT Project files
+(@pxref{Building DLLs with GNAT Project files}) to build DLLs.
+
+This section explains how to build DLLs containing Ada code using
+@code{gnatdll}. These DLLs will be referred to as Ada DLLs in the
+remainder of this section.
The steps required to build an Ada DLL that is to be used by Ada as well as
non-Ada applications are as follows:
with ALI; use ALI;
with Gnatvsn; use Gnatvsn;
with Hostparm;
+with Indepsw; use Indepsw;
with Namet; use Namet;
with Opt;
with Osint; use Osint;
Compile_Bind_File : Boolean := True;
-- Set to False if bind file is not to be compiled
+ Create_Map_File : Boolean := False;
+ -- Set to True by switch -M. The map file name is derived from
+ -- the ALI file name (mainprog.ali => mainprog.map).
+
Object_List_File_Supported : Boolean;
pragma Import
(C, Object_List_File_Supported, "__gnat_objlist_file_supported");
Binder_Options.Table (Binder_Options.Last) :=
Linker_Options.Table (Linker_Options.Last);
+ elsif Arg'Length >= 3 and then Arg (2) = 'M' then
+ declare
+ Switches : String_List_Access;
+ begin
+ Convert (Map_File, Arg (3 .. Arg'Last), Switches);
+
+ if Switches /= null then
+ for J in Switches'Range loop
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) :=
+ Switches (J);
+ end loop;
+ end if;
+ end;
+
elsif Arg'Length = 2 then
case Arg (2) is
when 'A' =>
("Object list file not supported on this target");
end if;
+ when 'M' =>
+ Create_Map_File := True;
+
when 'n' =>
Compile_Bind_File := False;
Write_Line (" -o nam Use 'nam' as the name of the executable");
Write_Line (" -b target Compile the binder source to run on target");
Write_Line (" -Bdir Load compiler executables from dir");
+
+ if Is_Supported (Map_File) then
+ Write_Line (" -Mmap Create map file map");
+ Write_Line (" -M Create map file mainprog.map");
+ end if;
+
Write_Line (" --GCC=comp Use comp as the compiler");
Write_Line (" --LINK=nam Use 'nam' for the linking rather than 'gcc'");
Write_Eol;
& """ may conflict with shell command");
end if;
+ -- If -M switch was specified, add the switches to create the map file
+
+ if Create_Map_File then
+ declare
+ Map_Name : constant String := Base_Name (Ali_File_Name.all) & ".map";
+ Switches : String_List_Access;
+
+ begin
+ Convert (Map_File, Map_Name, Switches);
+
+ if Switches /= null then
+ for J in Switches'Range loop
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) := Switches (J);
+ end loop;
+ end if;
+ end;
+ end if;
+
-- Perform consistency checks
-- Transform the .ali file name into the binder output file name
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- I N D E P S W --
+-- --
+-- B o d y --
+-- (AIX version) --
+-- --
+-- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 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 is the AIX version
+
+package body Indepsw is
+
+ Map_Switch : aliased constant String := "-Wl,-b,map:";
+
+ -------------
+ -- Convert --
+ -------------
+
+ procedure Convert
+ (Switch : Switch_Kind;
+ Argument : String;
+ To : out String_List_Access)
+ is
+ begin
+ case Switch is
+ when Map_File =>
+ To := new Argument_List'(1 => new String'(Map_Switch & Argument));
+ end case;
+ end Convert;
+
+ ------------------
+ -- Is_Supported --
+ ------------------
+
+ function Is_Supported (Switch : Switch_Kind) return Boolean is
+ begin
+ case Switch is
+ when Map_File =>
+ return True;
+ end case;
+ end Is_Supported;
+
+end Indepsw;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- I N D E P S W --
+-- --
+-- B o d y --
+-- (GNU/Linux version) --
+-- --
+-- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 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 is the GNU/Linux version
+
+package body Indepsw is
+
+ Map_Switch : aliased constant String := "-Wl,-Map,";
+
+ -------------
+ -- Convert --
+ -------------
+
+ procedure Convert
+ (Switch : Switch_Kind;
+ Argument : String;
+ To : out String_List_Access)
+ is
+ begin
+ case Switch is
+ when Map_File =>
+ To := new Argument_List'(1 => new String'(Map_Switch & Argument));
+ end case;
+ end Convert;
+
+ ------------------
+ -- Is_Supported --
+ ------------------
+
+ function Is_Supported (Switch : Switch_Kind) return Boolean is
+ begin
+ case Switch is
+ when Map_File =>
+ return True;
+ end case;
+ end Is_Supported;
+
+end Indepsw;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- I N D E P S W --
+-- --
+-- B o d y --
+-- (Windows version) --
+-- --
+-- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 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 is the Windows version
+
+package body Indepsw is
+
+ Map_Switch : aliased constant String := "-Wl,-Map,";
+
+ -------------
+ -- Convert --
+ -------------
+
+ procedure Convert
+ (Switch : Switch_Kind;
+ Argument : String;
+ To : out String_List_Access)
+ is
+ begin
+ case Switch is
+ when Map_File =>
+ To := new Argument_List'(1 => new String'(Map_Switch & Argument));
+ end case;
+ end Convert;
+
+ ------------------
+ -- Is_Supported --
+ ------------------
+
+ function Is_Supported (Switch : Switch_Kind) return Boolean is
+ begin
+ case Switch is
+ when Map_File =>
+ return True;
+ end case;
+ end Is_Supported;
+
+end Indepsw;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- I N D E P S W --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 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 is the default version: no switches are supported
+
+with Output; use Output;
+
+package body Indepsw is
+
+ -------------
+ -- Convert --
+ -------------
+
+ procedure Convert
+ (Switch : Switch_Kind;
+ Argument : String;
+ To : out String_List_Access)
+ is
+ pragma Unreferenced (Argument);
+ begin
+ case Switch is
+ when others =>
+ Write_Str ("warning: ");
+ Write_Line (No_Support_For (Switch).all);
+ To := null;
+ end case;
+ end Convert;
+
+ ------------------
+ -- Is_Supported --
+ ------------------
+
+ function Is_Supported (Switch : Switch_Kind) return Boolean is
+ pragma Unreferenced (Switch);
+ begin
+ return False;
+ end Is_Supported;
+
+end Indepsw;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- I N D E P S W --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2004 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- GNATLINK platform-independent switches
+
+-- Used to convert GNAT switches to their platform-dependent switch
+-- equivalent for the underlying linker.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package Indepsw is
+
+ type Switch_Kind is
+ -- Independent switches currently supported
+
+ (Map_File);
+ -- Produce a map file. The path name of the map file to produce
+ -- is given as an argument.
+
+ procedure Convert
+ (Switch : Switch_Kind;
+ Argument : String;
+ To : out String_List_Access);
+ -- Convert Switch to the platform-dependent linker switch (with or without
+ -- additional arguments) To. Issue a warning if Switch is not supported
+ -- for the platform; in this case, To is set to null.
+
+ function Is_Supported (Switch : Switch_Kind) return Boolean;
+ -- Return True for each independent switch supported by the platform.
+
+private
+ -- Default warning messages when the switches are not supported by the
+ -- implementation. These are in the spec so that the platform specific
+ -- bodies do not need to redefine them.
+
+ Map_File_Not_Supported : aliased String :=
+ "the underlying linker does not allow the output of a map file";
+
+ No_Support_For : constant array (Switch_Kind) of String_Access :=
+ (Map_File => Map_File_Not_Supported'Access);
+ -- All implementations of procedure Convert should include a case
+ -- statements with a "when others =>" choice that output the default
+ -- warning message:
+
+ -- case Switch is
+ -- when ... =>
+ -- ...
+ -- when others =>
+ -- Write_Str ("warning: ");
+ -- Write_Line (No_Support_For (Switch).all);
+ -- To := null;
+ -- end case;
+
+end Indepsw;
Object_Name : Name_Id;
Time_Stamp : Time_Stamp_Type;
+ Driver_Name : Name_Id := No_Name;
begin
Check_Archive_Builder;
Last_Argument := 0;
- -- If there are sources in Ada, then gnatmake will build the
- -- library, so nothing to do.
+ -- If there are sources in Ada, then gnatmake will build the
+ -- library, so nothing to do.
- if not Data.Languages (Lang_Ada) then
+ if not Data.Languages (Lang_Ada) then
- -- Get all the object files of the project
+ -- Get all the object files of the project
- Source_Id := Data.First_Other_Source;
+ Source_Id := Data.First_Other_Source;
- while Source_Id /= No_Other_Source loop
- Source := Other_Sources.Table (Source_Id);
- Add_Argument
- (Get_Name_String (Source.Object_Name), Verbose_Mode);
- Source_Id := Source.Next;
- end loop;
+ while Source_Id /= No_Other_Source loop
+ Source := Other_Sources.Table (Source_Id);
+ Add_Argument
+ (Get_Name_String (Source.Object_Name), Verbose_Mode);
+ Source_Id := Source.Next;
+ end loop;
- -- If it is a library, it need to be built it the same way
- -- Ada libraries are built.
+ -- If it is a library, it need to be built it the same way
+ -- Ada libraries are built.
- if Data.Library_Kind = Static then
- MLib.Build_Library
- (Ofiles => Arguments (1 .. Last_Argument),
- Afiles => No_Argument,
- Output_File => Get_Name_String (Data.Library_Name),
- Output_Dir => Get_Name_String (Data.Library_Dir));
+ if Data.Library_Kind = Static then
+ MLib.Build_Library
+ (Ofiles => Arguments (1 .. Last_Argument),
+ Afiles => No_Argument,
+ Output_File => Get_Name_String (Data.Library_Name),
+ Output_Dir => Get_Name_String (Data.Library_Dir));
- else
- MLib.Tgt.Build_Dynamic_Library
- (Ofiles => Arguments (1 .. Last_Argument),
- Foreign => Arguments (1 .. Last_Argument),
- Afiles => No_Argument,
- Options => No_Argument,
- Interfaces => No_Argument,
- Lib_Filename => Get_Name_String (Data.Library_Name),
- Lib_Dir => Get_Name_String (Data.Library_Dir),
- Symbol_Data => No_Symbols,
- Driver_Name => No_Name,
- Lib_Version => "",
- Auto_Init => False);
+ else
+ -- Link with g++ if C++ is one of the languages, otherwise
+ -- building the library may fail with unresolved symbols.
+
+ if C_Plus_Plus_Is_Used then
+ if Compiler_Names (Lang_C_Plus_Plus) = null then
+ Get_Compiler (Lang_C_Plus_Plus);
+ end if;
+
+ if Compiler_Is_Gcc (Lang_C_Plus_Plus) then
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer
+ (Compiler_Names (Lang_C_Plus_Plus).all);
+ Driver_Name := Name_Find;
+ end if;
end if;
- end if;
- -- Create fake empty archive, so we can check its time stamp later
+ MLib.Tgt.Build_Dynamic_Library
+ (Ofiles => Arguments (1 .. Last_Argument),
+ Foreign => Arguments (1 .. Last_Argument),
+ Afiles => No_Argument,
+ Options => No_Argument,
+ Interfaces => No_Argument,
+ Lib_Filename => Get_Name_String (Data.Library_Name),
+ Lib_Dir => Get_Name_String (Data.Library_Dir),
+ Symbol_Data => No_Symbols,
+ Driver_Name => Driver_Name,
+ Lib_Version => "",
+ Auto_Init => False);
+ end if;
+ end if;
- declare
- Archive : Ada.Text_IO.File_Type;
- use Ada.Text_IO;
- begin
- Create (Archive, Out_File, Archive_Name);
- Close (Archive);
- end;
+ -- Create fake empty archive, so we can check its time stamp later
- Create_Archive_Dependency_File
- (Archive_Dep_Name, Data.First_Other_Source);
+ declare
+ Archive : Ada.Text_IO.File_Type;
+ use Ada.Text_IO;
+ begin
+ Create (Archive, Out_File, Archive_Name);
+ Close (Archive);
+ end;
+ Create_Archive_Dependency_File
+ (Archive_Dep_Name, Data.First_Other_Source);
end if;
end Build_Library;
Need_To_Rebuild_Global_Archive := True;
end if;
- -- If there was no compilation error, build/rebuild the archive
- -- if necessary.
+ -- If there was no compilation error and -c was not used,
+ -- build / rebuild the archive if necessary.
if not Local_Errors
and then Data.Library
and then not Data.Languages (Lang_Ada)
+ and then not Compile_Only
then
Build_Library (Project, Need_To_Rebuild_Archive);
end if;
end if;
else
- -- First compile sources and build archives for library project,
+ -- First check for C++, to link libraries with g++, rather than gcc
+
+ Check_For_C_Plus_Plus;
+
+ -- Compile sources and build archives for library project,
-- if necessary.
Compile_Sources;
if not Compile_Only then
Build_Global_Archive;
- Check_For_C_Plus_Plus;
Link_Executables;
end if;
Tools.Gcc
(Output_File => Lib_File,
Objects => Ofiles,
- Options => Options,
+ Options => Tools.No_Argument_List,
+ Options_2 => Options,
Driver_Name => Driver_Name);
end Build_Dynamic_Library;
end if;
if For_Language = Lang_Ada then
- -- If we have looked for sources and found none, then
- -- it is an error, except if it is an extending project.
- -- If a non extending project is not supposed to contain
- -- any source, then we never call Find_Sources.
- -- No error either when setting up projects (gnat setup).
+
+ -- If we have looked for sources and found none, then it is an
+ -- error, except if it is an extending project. If a non-extending
+ -- project is not supposed to contain any source, then we never
+ -- Find_Sources. No error is signalled when setting up projects
+ -- using gnat setup.
if Current_Source /= Nil_String then
Data.Ada_Sources_Present := True;
Object_Dir.Location);
else
- -- We check that the specified object directory
- -- does exist, and attempt to create it if setting up projects
- -- (gnat setup).
+ -- Check that the specified object directory does exist, and
+ -- attempt to create it if setting up projects (gnat setup).
Locate_Directory
(Object_Dir.Value, Data.Display_Directory,
and then Data.Object_Directory = No_Name
then
-- The object directory does not exist, report an error
+
Err_Vars.Error_Msg_Name_1 := Object_Dir.Value;
Error_Msg
(Project,
Data.Location);
-- Do not keep a nil Object_Directory. Set it to the
- -- specified (relative or absolute) path.
- -- This is for the benefit of tools that recover from
- -- errors; for example, these tools could create the
- -- non existent directory.
+ -- specified (relative or absolute) path. This is for the
+ -- benefit of tools that recover from errors. For example,
+ -- these tools could create the non-existent directory.
Data.Display_Object_Dir := Object_Dir.Value;
Get_Name_String (Object_Dir.Value);
elsif Source_Dirs.Values = Nil_String then
- -- If Source_Dirs is an empty string list, this means
- -- that this project contains no source. For projects that
- -- don't extend other projects, this also means that there is no
- -- need for an object directory, if not specified.
+ -- If Source_Dirs is an empty string list, this means that this
+ -- contains no sources. For projects that do not extend other
+ -- projects, this also means that there is no need for an object
+ -- directory unless one is specified explicitly.
if Data.Extends = No_Project
and then Data.Object_Directory = Data.Directory
begin
-- If the project extended is a library project, we inherit
- -- the library name, if it is not redefined; we check that
- -- the library directory is specified; and we reset the
+ -- the library name, if it is not redefined, we check that
+ -- the library directory is specified, and we reset the
-- library flag for the extended project.
if Extended_Data.Library then
-- Check Spec_Suffix
declare
- Spec_Suffixs : Array_Element_Id :=
- Util.Value_Of
- (Name_Spec_Suffix,
- Naming.Decl.Arrays);
+ Spec_Suffixes : Array_Element_Id :=
+ Util.Value_Of
+ (Name_Spec_Suffix,
+ Naming.Decl.Arrays);
Suffix : Array_Element_Id;
Element : Array_Element;
Suffix2 : Array_Element_Id;
begin
- -- If some suffixs have been specified, we make sure that
+ -- If some suffixes have been specified, we make sure that
-- for each language for which a default suffix has been
-- specified, there is a suffix specified, either the one
-- in the project file or if there were none, the default.
- if Spec_Suffixs /= No_Array_Element then
+ if Spec_Suffixes /= No_Array_Element then
Suffix := Data.Naming.Spec_Suffix;
while Suffix /= No_Array_Element loop
Element := Array_Elements.Table (Suffix);
- Suffix2 := Spec_Suffixs;
+ Suffix2 := Spec_Suffixes;
while Suffix2 /= No_Array_Element loop
exit when Array_Elements.Table (Suffix2).Index =
Suffix2 := Array_Elements.Table (Suffix2).Next;
end loop;
- -- There is a registered default suffix, but no
- -- suffix specified in the project file.
- -- Add the default to the array.
+ -- There is a registered default suffix, but no suffix is
+ -- specified in the project file. Add default to array.
if Suffix2 = No_Array_Element then
Array_Elements.Increment_Last;
Src_Index => Element.Src_Index,
Index_Case_Sensitive => False,
Value => Element.Value,
- Next => Spec_Suffixs);
- Spec_Suffixs := Array_Elements.Last;
+ Next => Spec_Suffixes);
+ Spec_Suffixes := Array_Elements.Last;
end if;
Suffix := Element.Next;
end loop;
- -- Put the resulting array as the specification suffixs
+ -- Put the resulting array as the specification suffixes
- Data.Naming.Spec_Suffix := Spec_Suffixs;
+ Data.Naming.Spec_Suffix := Spec_Suffixes;
end if;
end;
-- Check Body_Suffix
declare
- Impl_Suffixs : Array_Element_Id :=
- Util.Value_Of
- (Name_Body_Suffix,
- Naming.Decl.Arrays);
+ Impl_Suffixes : Array_Element_Id :=
+ Util.Value_Of
+ (Name_Body_Suffix, Naming.Decl.Arrays);
Suffix : Array_Element_Id;
Element : Array_Element;
Suffix2 : Array_Element_Id;
begin
- -- If some suffixs have been specified, we make sure that
+ -- If some suffixes have been specified, we make sure that
-- for each language for which a default suffix has been
-- specified, there is a suffix specified, either the one
-- in the project file or if there were noe, the default.
- if Impl_Suffixs /= No_Array_Element then
+ if Impl_Suffixes /= No_Array_Element then
Suffix := Data.Naming.Body_Suffix;
while Suffix /= No_Array_Element loop
Element := Array_Elements.Table (Suffix);
- Suffix2 := Impl_Suffixs;
+ Suffix2 := Impl_Suffixes;
while Suffix2 /= No_Array_Element loop
exit when Array_Elements.Table (Suffix2).Index =
Src_Index => Element.Src_Index,
Index_Case_Sensitive => False,
Value => Element.Value,
- Next => Impl_Suffixs);
- Impl_Suffixs := Array_Elements.Last;
+ Next => Impl_Suffixes);
+ Impl_Suffixes := Array_Elements.Last;
end if;
Suffix := Element.Next;
end loop;
- -- Put the resulting array as the implementation suffixs
+ -- Put the resulting array as the implementation suffixes
- Data.Naming.Body_Suffix := Impl_Suffixs;
+ Data.Naming.Body_Suffix := Impl_Suffixes;
end if;
end;
Language_Independent_Checked : Boolean := False;
-- A flag that indicates that the project file has been checked
-- for language independent features: Object_Directory,
- -- Source_Directories, Library, non empty Naming Suffixs.
+ -- Source_Directories, Library, non empty Naming Suffixes.
Checked : Boolean := False;
-- A flag to avoid checking repetitively the naming scheme of
(Language : Name_Id;
Default_Spec_Suffix : Name_Id;
Default_Body_Suffix : Name_Id);
- -- Register the default suffixs for a given language. These extensions
+ -- Register the default suffixes for a given language. These extensions
-- will be ignored if the user has specified a new naming scheme in a
-- project file.
--
-- then the secondary stack is allocated statically by grabbing a
-- section of the primary stack and using it for this purpose.
- type Memory is array (Mark_Id range <>) of SSE.Storage_Element;
+ type Memory is array (SS_Ptr range <>) of SSE.Storage_Element;
for Memory'Alignment use Standard'Maximum_Alignment;
-- This is the type used for actual allocation of secondary stack
-- areas. We require maximum alignment for all such allocations.
-- +-----------------+ +------------------+
--
- type Chunk_Id (First, Last : Mark_Id);
+ type Chunk_Id (First, Last : SS_Ptr);
type Chunk_Ptr is access all Chunk_Id;
- type Chunk_Id (First, Last : Mark_Id) is record
+ type Chunk_Id (First, Last : SS_Ptr) is record
Prev, Next : Chunk_Ptr;
Mem : Memory (First .. Last);
end record;
type Stack_Id is record
- Top : Mark_Id;
+ Top : SS_Ptr;
Default_Size : SSE.Storage_Count;
Current_Chunk : Chunk_Ptr;
end record;
-- by the following data strcuture
type Fixed_Stack_Id is record
- Top : Mark_Id;
+ Top : SS_Ptr;
-- Index of next available location in Mem. This is initialized to
-- 0, and then incremented on Allocate, and Decremented on Release.
- Last : Mark_Id;
+ Last : SS_Ptr;
-- Length of usable Mem array, which is thus the index past the
-- last available location in Mem. Mem (Last-1) can be used. This
-- is used to check that the stack does not overflow.
- Max : Mark_Id;
+ Max : SS_Ptr;
-- Maximum value of Top. Initialized to 0, and then may be incremented
-- on Allocate, but is never Decremented. The last used location will
-- be Mem (Max - 1), so Max is the maximum count of used stack space.
(Addr : out Address;
Storage_Size : SSE.Storage_Count)
is
- Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
- Max_Size : constant Mark_Id :=
- ((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align)
+ Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
+ Max_Size : constant SS_Ptr :=
+ ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align)
* Max_Align;
begin
Chunk.Next :=
new Chunk_Id
(First => Chunk.Last + 1,
- Last => Chunk.Last + Mark_Id (Stack.Default_Size));
+ Last => Chunk.Last + SS_Ptr (Stack.Default_Size));
Chunk.Next.Prev := Chunk;
begin
Put_Line (
" Total size : "
- & Mark_Id'Image (Fixed_Stack.Last)
+ & SS_Ptr'Image (Fixed_Stack.Last)
& " bytes");
Put_Line (
" Current allocated space : "
- & Mark_Id'Image (Fixed_Stack.Top - 1)
+ & SS_Ptr'Image (Fixed_Stack.Top - 1)
& " bytes");
end;
Put_Line (
" Total size : "
- & Mark_Id'Image (Chunk.Last)
+ & SS_Ptr'Image (Chunk.Last)
& " bytes");
Put_Line (
" Current allocated space : "
- & Mark_Id'Image (Stack.Top - 1)
+ & SS_Ptr'Image (Stack.Top - 1)
& " bytes");
Put_Line (
Fixed_Stack.Last := 0;
else
Fixed_Stack.Last :=
- Mark_Id (Size) - Dummy_Fixed_Stack.Mem'Position;
+ SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position;
end if;
end;
Stack : Stack_Ptr;
begin
Stack := new Stack_Id;
- Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size));
+ Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size));
Stack.Top := 1;
Stack.Default_Size := SSE.Storage_Count (Size);
Stk := To_Addr (Stack);
-------------
function SS_Mark return Mark_Id is
+ Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all;
begin
if SS_Ratio_Dynamic then
- return To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top;
+ return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top);
else
- return To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top;
+ return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top);
end if;
end SS_Mark;
procedure SS_Release (M : Mark_Id) is
begin
if SS_Ratio_Dynamic then
- To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+ To_Stack_Ptr (M.Sstk).Top := M.Sptr;
else
- To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+ To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr;
end if;
end SS_Release;
Stack : aliased Stack_Id;
for Stack'Alignment use Standard'Maximum_Alignment;
- Chunk : aliased Chunk_Id (1, Mark_Id (Default_Secondary_Stack_Size));
+ Chunk : aliased Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size));
for Chunk'Alignment use Standard'Maximum_Alignment;
Chunk_Address : Address;
-- to System.Null_Address.
type Mark_Id is private;
- -- Type used to mark the stack
+ -- Type used to mark the stack for mark/release processing
function SS_Mark return Mark_Id;
-- Return the Mark corresponding to the current state of the stack
-- Unused entity that is just present to ease the sharing of the pool
-- mechanism for specific allocation/deallocation in the compiler
- type Mark_Id is new SSE.Integer_Address;
+ type SS_Ptr is new SSE.Integer_Address;
+ -- Stack pointer value for secondary stack
+
+ type Mark_Id is record
+ Sstk : System.Address;
+ Sptr : SS_Ptr;
+ end record;
+ -- A mark value contains the address of the secondary stack structure,
+ -- as returned by System.Soft_Links.Get_Sec_Stack_Addr, and a stack
+ -- pointer value corresponding to the point of the mark call.
end System.Secondary_Stack;
-- --
------------------------------------------------------------------------------
--- This package contains the tasking versions soft links.
-
pragma Style_Checks (All_Checks);
-- Turn off subprogram alpha ordering check, since we group soft link
-- bodies and dummy soft link bodies together separately in this unit.
-- Boolean flag that indicates whether the tasking soft links have
-- already been set.
- ----------------------------------------------------------------------
- -- Tasking versions of some services needed by non-tasking programs --
- ----------------------------------------------------------------------
+ -----------------------------------------------------------------
+ -- Tasking Versions of Services Needed by Non-Tasking Programs --
+ -----------------------------------------------------------------
function Get_Jmpbuf_Address return Address;
procedure Set_Jmpbuf_Address (Addr : Address);
procedure Init_Tasking_Soft_Links is
begin
- -- If the tasking soft links have already been initialized do not
- -- repeat it.
+ -- Set links only if not set already
if not Initialized then
+
-- Mark tasking soft links as initialized
Initialized := True;
SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
end if;
-
end Init_Tasking_Soft_Links;
end System.Soft_Links.Tasking;
-- This package contains the tasking versions soft links that are common
-- to the full and the restricted run times. The rest of the required soft
-- links are set by System.Tasking.Initialization and System.Tasking.Stages
--- (full run time) or System.Tasking.Restricted.Stages (restricted run
--- time).
+-- (full run time) or System.Tasking.Restricted.Stages (restricted run time).
package System.Soft_Links.Tasking is
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1998-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 x86 VxWorks version of this package
+
+package System.VxWorks is
+ pragma Preelaborate (System.VxWorks);
+
+ -- Floating point context record. x86 version
+
+ -- For now this is a dummy implementation (more work needed ???)
+
+ type FP_CONTEXT is record
+ Dummy : Integer;
+ end record;
+
+ for FP_CONTEXT'Alignment use 4;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+ -- Number of entries in hardware interrupt vector table
+
+end System.VxWorks;
when Attribute_Size | Attribute_VADS_Size =>
Check_E0;
- if Is_Object_Reference (P)
- or else (Is_Entity_Name (P)
- and then Ekind (Entity (P)) = E_Function)
+ -- If prefix is parameterless function call, rewrite and resolve
+ -- as such.
+
+ if Is_Entity_Name (P)
+ and then Ekind (Entity (P)) = E_Function
then
+ Resolve (P);
+
+ -- Similar processing for a protected function call
+
+ elsif Nkind (P) = N_Selected_Component
+ and then Ekind (Entity (Selector_Name (P))) = E_Function
+ then
+ Resolve (P);
+ end if;
+
+ if Is_Object_Reference (P) then
Check_Object_Reference (P);
elsif Is_Entity_Name (P)
-- outside a generic body when the subprogram is declared
-- within that generic body.
- elsif Enclosing_Generic_Body (Entity (P))
- /= Enclosing_Generic_Body (Btyp)
+ elsif Present (Enclosing_Generic_Body (Entity (P)))
+ and then Enclosing_Generic_Body (Entity (P)) /=
+ Enclosing_Generic_Body (Btyp)
then
Error_Msg_N
("access type must not be outside generic body", P);
end if;
end if;
- -- if this is a renaming, an inherited operation, or a
+ -- If this is a renaming, an inherited operation, or a
-- subprogram instance, use the original entity.
if Is_Entity_Name (P)
elsif Is_Overloaded (P) then
- -- Use the designated type of the context to disambiguate.
+ -- Use the designated type of the context to disambiguate
+
declare
Index : Interp_Index;
It : Interp;
-- Finally perform static evaluation on the attribute reference
Eval_Attribute (N);
-
end Resolve_Attribute;
end Sem_Attr;
Rewrite (N, Make_Null_Statement (Sloc (N)));
end if;
end if;
-
end Analyze_Raise_xxx_Error;
-----------------------------
else
Act_T := Entity (Actual);
+ -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
+ -- as a generic actual parameter if the corresponding formal type
+ -- does not have a known_discriminant_part, or is a formal derived
+ -- type that is an Unchecked_Union type.
+
+ if Is_Unchecked_Union (Base_Type (Act_T)) then
+ if not Has_Discriminants (A_Gen_T)
+ or else
+ (Is_Derived_Type (A_Gen_T)
+ and then
+ Is_Unchecked_Union (A_Gen_T))
+ then
+ null;
+ else
+ Error_Msg_N ("Unchecked_Union cannot be the actual for a" &
+ " discriminated formal type", Act_T);
+
+ end if;
+ end if;
+
-- Deal with fixed/floating restrictions
if Is_Floating_Point_Type (Act_T) then
T : Entity_Id;
P : Entity_Id;
+ function Contains_POC (Constr : Node_Id) return Boolean;
+ -- Determines whether a constraint uses the discriminant of a record
+ -- type thus becoming a per-object constraint (POC).
+
+ ------------------
+ -- Contains_POC --
+ ------------------
+
+ function Contains_POC (Constr : Node_Id) return Boolean is
+ begin
+ case Nkind (Constr) is
+
+ when N_Attribute_Reference =>
+ return Attribute_Name (Constr) = Name_Access
+ and
+ Prefix (Constr) = Scope (Entity (Prefix (Constr)));
+
+ when N_Discriminant_Association =>
+ return Denotes_Discriminant (Expression (Constr));
+
+ when N_Identifier =>
+ return Denotes_Discriminant (Constr);
+
+ when N_Index_Or_Discriminant_Constraint =>
+ declare
+ IDC : Node_Id := First (Constraints (Constr));
+ begin
+ while Present (IDC) loop
+
+ -- One per-object constraint is sufficent
+
+ if Contains_POC (IDC) then
+ return True;
+ end if;
+
+ Next (IDC);
+ end loop;
+
+ return False;
+ end;
+
+ when N_Range =>
+ return Denotes_Discriminant (Low_Bound (Constr))
+ or
+ Denotes_Discriminant (High_Bound (Constr));
+
+ when N_Range_Constraint =>
+ return Denotes_Discriminant (Range_Expression (Constr));
+
+ when others =>
+ return False;
+
+ end case;
+ end Contains_POC;
+
+ -- Start of processing for Analyze_Component_Declaration
+
begin
Generate_Definition (Id);
Enter_Name (Id);
Set_Etype (Id, T);
Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N)));
+ -- The component declaration may have a per-object constraint, set the
+ -- appropriate flag in the defining identifier of the subtype.
+
+ if Present (Subtype_Indication (Component_Definition (N))) then
+ declare
+ Sindic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (N));
+
+ begin
+ if Nkind (Sindic) = N_Subtype_Indication
+ and then Present (Constraint (Sindic))
+ and then Contains_POC (Constraint (Sindic))
+ then
+ Set_Has_Per_Object_Constraint (Id);
+ end if;
+ end;
+ end if;
+
-- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
-- out some static checks
return;
- elsif Is_Unchecked_Union (Parent_Type) then
- Error_Msg_N ("cannot derive from Unchecked_Union type", N);
-
-- Ada 2005 (AI-231): Static check
elsif Is_Access_Type (Parent_Type)
P := Parent (S);
Subtype_Mark_Id := Entity (Subtype_Mark (S));
- if Is_Unchecked_Union (Subtype_Mark_Id)
- and then Comes_From_Source (Related_Nod)
- then
- Error_Msg_N
- ("cannot create subtype of Unchecked_Union", Related_Nod);
- end if;
-
-- Explicit subtype declaration case
if Nkind (P) = N_Subtype_Declaration then
Set_Etype (Sel, Etype (Comp));
if Ekind (Comp) = E_Discriminant then
- if Is_Unchecked_Union (Prefix_Type) then
+ if Is_Unchecked_Union (Base_Type (Prefix_Type)) then
Error_Msg_N
("cannot reference discriminant of Unchecked_Union",
Sel);
--------------------------
function Try_Object_Operation (N : Node_Id) return Boolean is
- Obj : constant Node_Id := Prefix (N);
- Obj_Type : Entity_Id;
- Actual : Node_Id;
- Last_Node : Node_Id;
- -- Last_Node is used to free all the nodes generated while trying the
- -- alternatives. NOTE: This must be removed because it is considered
- -- too low level
+ Obj : constant Node_Id := Prefix (N);
+ Obj_Type : Entity_Id;
+ Actual : Node_Id;
+
+ Last_Node : Node_Id;
+ -- Used to free all the nodes generated while trying the alternatives.
+ -- To me removed later, too low level ???
+
use Atree_Private_Part;
function Try_Replacement
-- Nam_Ent is the entity that provides the formals against which
-- the actuals are checked. If the actuals are compatible with
-- Ent_Nam, this function returns true.
+ -- Document other parameters, also what is Ent_Nam???
function Try_Primitive_Operations
(New_Prefix : Entity_Id;
New_Subprg : Node_Id;
Obj : Node_Id;
Obj_Type : Entity_Id) return Boolean;
- -- Traverse the list of primitive subprograms to look for the
+ -- Traverse list of primitive subprograms to look for the subprogram
+ -- Parameters should be documented ???
-- subprogram.
function Try_Class_Wide_Operation
(New_Subprg : Node_Id;
Obj : Node_Id;
Obj_Type : Entity_Id) return Boolean;
- -- Traverse all the ancestor types to look for a class-wide
- -- subprogram
+ -- Traverse all the ancestor types to look for a class-wide subprogram
+ -- Parameters should be documented ???
------------------------------
-- Try_Primitive_Operations --
Obj : Node_Id;
Obj_Type : Entity_Id) return Boolean
is
- Deref : Node_Id;
- Elmt : Elmt_Id;
- Prim_Op : Entity_Id;
+ Deref : Node_Id;
+ Elmt : Elmt_Id;
+ Prim_Op : Entity_Id;
begin
-- Look for the subprogram in the list of primitive operations.
-- analysis after the node replacement will resolve it.
Elmt := First_Elmt (Primitive_Operations (Obj_Type));
-
while Present (Elmt) loop
Prim_Op := Node (Elmt);
Obj : Node_Id;
Obj_Type : Entity_Id) return Boolean
is
- Deref : Node_Id;
- Hom : Entity_Id;
- Typ : Entity_Id;
+ Deref : Node_Id;
+ Hom : Entity_Id;
+ Typ : Entity_Id;
begin
- Typ := Obj_Type;
+ -- Loop through ancestor types
+ Typ := Obj_Type;
loop
-- For each parent subtype we traverse all the homonym chain
-- looking for a candidate class-wide subprogram
Hom := Current_Entity (New_Subprg);
-
while Present (Hom) loop
if (Ekind (Hom) = E_Procedure
or else Ekind (Hom) = E_Function)
Hom := Homonym (Hom);
end loop;
- exit when Etype (Typ) = Typ;
+ -- Climb to ancestor type if there is one
- Typ := Etype (Typ); -- Climb to the ancestor type
+ exit when Etype (Typ) = Typ;
+ Typ := Etype (Typ);
end loop;
return False;
if (Nkind (Parent (N)) = N_Procedure_Call_Statement
or else Nkind (Parent (N)) = N_Function_Call)
- and then N /= First (Parameter_Associations (Parent (N)))
- -- Protect against recursive call; It occurs in "..:= F (O.P)"
+
+ -- Protect against recursive call; It occurs in "..:= F (O.P)"
+
+ and then N /= First (Parameter_Associations (Parent (N)))
+
then
Node_To_Replace := Parent (N);
-- Previous analysis transformed the node with the name
-- and we have to reset it to properly re-analyze it.
- New_Name := Make_Selected_Component (Loc,
- Prefix => New_Reference_To (New_Prefix, Loc),
- Selector_Name => New_Copy_Tree (New_Subprg));
+ New_Name :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (New_Prefix, Loc),
+ Selector_Name => New_Copy_Tree (New_Subprg));
Set_Name (Call_Node, New_Name);
Set_Analyzed (Call_Node, False);
return True;
-- Free all the nodes used for this test and return
+
else
Nodes.Set_Last (Last_Node);
return False;
if (Nkind (Parent (N)) = N_Procedure_Call_Statement
or else Nkind (Parent (N)) = N_Function_Call)
- and then N /= First (Parameter_Associations (Parent (N)))
- -- Protects against recursive call in case of "..:= F (O.Proc)"
+
+ -- Protects against recursive call in case of "..:= F (O.Proc)"
+
+ and then N /= First (Parameter_Associations (Parent (N)))
then
Actual := First (Parameter_Associations (Parent (N)));
----------------------------
procedure Analyze_Case_Statement (N : Node_Id) is
+ Exp : Node_Id;
+ Exp_Type : Entity_Id;
+ Exp_Btype : Entity_Id;
+ Last_Choice : Nat;
+ Dont_Care : Boolean;
+ Others_Present : Boolean;
Statements_Analyzed : Boolean := False;
-- Set True if at least some statement sequences get analyzed.
------------------------
procedure Process_Statements (Alternative : Node_Id) is
+ Choices : constant List_Id := Discrete_Choices (Alternative);
+ Ent : Entity_Id;
+
begin
Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
Statements_Analyzed := True;
+
+ -- An interesting optimization. If the case statement expression
+ -- is a simple entity, then we can set the current value within
+ -- an alternative if the alternative has one possible value.
+
+ -- case N is
+ -- when 1 => alpha
+ -- when 2 | 3 => beta
+ -- when others => gamma
+
+ -- Here we know that N is initially 1 within alpha, but for beta
+ -- and gamma, we do not know anything more about the initial value.
+
+ if Is_Entity_Name (Exp) then
+ Ent := Entity (Exp);
+
+ if Ekind (Ent) = E_Variable
+ or else
+ Ekind (Ent) = E_In_Out_Parameter
+ or else
+ Ekind (Ent) = E_Out_Parameter
+ then
+ if List_Length (Choices) = 1
+ and then Nkind (First (Choices)) in N_Subexpr
+ and then Compile_Time_Known_Value (First (Choices))
+ then
+ Set_Current_Value (Entity (Exp), First (Choices));
+ end if;
+
+ Analyze_Statements (Statements (Alternative));
+
+ -- After analyzing the case, set the current value to empty
+ -- since we won't know what it is for the next alternative
+ -- (unless reset by this same circuit), or after the case.
+
+ Set_Current_Value (Entity (Exp), Empty);
+ return;
+ end if;
+ end if;
+
+ -- Case where expression is not an entity name of a variable
+
Analyze_Statements (Statements (Alternative));
end Process_Statements;
- -- Variables local to Analyze_Case_Statement.
-
- Exp : Node_Id;
- Exp_Type : Entity_Id;
- Exp_Btype : Entity_Id;
+ -- Table to record choices. Put after subprograms since we make
+ -- a call to Number_Of_Choices to get the right number of entries.
- Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
- Last_Choice : Nat;
- Dont_Care : Boolean;
- Others_Present : Boolean;
+ Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
-- Start of processing for Analyze_Case_Statement
Formal_Type := Etype (Formal);
end if;
+ -- Do not produce extra formals for Unchecked_Union parameters.
+ -- Jump directly to the end of the loop.
+
+ if Is_Unchecked_Union (Base_Type (Formal_Type)) then
+ goto Skip_Extra_Formal_Generation;
+ end if;
+
if not Has_Discriminants (Formal_Type)
and then Ekind (Formal_Type) in Private_Kind
and then Present (Underlying_Type (Formal_Type))
Next_Formal (P_Formal);
end if;
+ -- This label is required when skipping extra formal generation for
+ -- Unchecked_Union parameters.
+
+ <<Skip_Extra_Formal_Generation>>
+
Next_Formal (Formal);
end loop;
end Create_Extra_Formals;
elsif Is_Record_Type (T)
and then Ekind (Formal) = E_In_Parameter
and then Chars (Formal) /= Name_uInit
+ and then not Is_Unchecked_Union (T)
and then not Is_Discrim_SO_Function (Subp)
then
AS_Needed := True;
-- is a public child of Parent as defined in 10.1.1
procedure Inspect_Deferred_Constant_Completion;
- -- Examines the deferred constants in the private part of the
- -- package specification. Emits the error "constant declaration
- -- requires initialization expression " if not completed by an
- -- import pragma.
+ -- Examines the deferred constants in the private part of the package
+ -- specification. Emits the error message "constant declaration requires
+ -- initialization expression " if not completed by an Import pragma.
+
+ procedure Inspect_Unchecked_Union_Completion (Decls : List_Id);
+ -- Detects all incomplete or private type declarations having a known
+ -- discriminant part that are completed by an Unchecked_Union. Emits
+ -- the error message "Unchecked_Union may not complete discriminated
+ -- partial view".
---------------------
-- Clear_Constants --
end loop;
end Inspect_Deferred_Constant_Completion;
+ ----------------------------------------
+ -- Inspect_Unchecked_Union_Completion --
+ ----------------------------------------
+
+ procedure Inspect_Unchecked_Union_Completion (Decls : List_Id) is
+ Decl : Node_Id := First (Decls);
+
+ begin
+ while Present (Decl) loop
+
+ -- We are looking at an incomplete or private type declaration
+ -- with a known_discriminant_part whose full view is an
+ -- Unchecked_Union.
+
+ if (Nkind (Decl) = N_Incomplete_Type_Declaration
+ or else
+ Nkind (Decl) = N_Private_Type_Declaration)
+ and then Has_Discriminants (Defining_Identifier (Decl))
+ and then Present (Full_View (Defining_Identifier (Decl)))
+ and then Is_Unchecked_Union
+ (Full_View (Defining_Identifier (Decl)))
+ then
+ Error_Msg_N ("completion of discriminated partial view" &
+ " cannot be an Unchecked_Union",
+ Full_View (Defining_Identifier (Decl)));
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Inspect_Unchecked_Union_Completion;
+
-- Start of processing for Analyze_Package_Specification
begin
Next_Entity (E);
end loop;
+ -- Ada 2005 (AI-216): The completion of an incomplete or private type
+ -- declaration having a known_discriminant_part shall not be an
+ -- Unchecked_Union type.
+
+ if Present (Vis_Decls) then
+ Inspect_Unchecked_Union_Completion (Vis_Decls);
+ end if;
+
+ if Present (Priv_Decls) then
+ Inspect_Unchecked_Union_Completion (Priv_Decls);
+ end if;
+
if Ekind (Id) = E_Generic_Package
and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
and then Present (Priv_Decls)
while Present (Id) loop
Install_Package_Entity (Id);
+ Set_Is_Hidden (Id, False);
Next_Entity (Id);
end loop;
procedure Eval_Integer_Literal (N : Node_Id) is
T : constant Entity_Id := Etype (N);
+ function In_Any_Integer_Context return Boolean;
+ -- If the literal is resolved with a specific type in a context
+ -- where the expected type is Any_Integer, there are no range checks
+ -- on the literal. By the time the literal is evaluated, it carries
+ -- the type imposed by the enclosing expression, and we must recover
+ -- the context to determine that Any_Integer is meant.
+
+ ----------------------------
+ -- To_Any_Integer_Context --
+ ----------------------------
+
+ function In_Any_Integer_Context return Boolean is
+ Par : constant Node_Id := Parent (N);
+ K : constant Node_Kind := Nkind (Par);
+
+ begin
+ -- Any_Integer also appears in digits specifications for real types,
+ -- but those have bounds smaller that those of any integer base
+ -- type, so we can safely ignore these cases.
+
+ return K = N_Number_Declaration
+ or else K = N_Attribute_Reference
+ or else K = N_Attribute_Definition_Clause
+ or else K = N_Modular_Type_Definition
+ or else K = N_Signed_Integer_Type_Definition;
+ end In_Any_Integer_Context;
+
+ -- Start of processing for Eval_Integer_Literal
+
begin
+
-- If the literal appears in a non-expression context, then it is
-- certainly appearing in a non-static context, so check it. This
-- is actually a redundant check, since Check_Non_Static_Context
-- would check it, but it seems worth while avoiding the call.
- if Nkind (Parent (N)) not in N_Subexpr then
+ if Nkind (Parent (N)) not in N_Subexpr
+ and then not In_Any_Integer_Context
+ then
Check_Non_Static_Context (N);
end if;
procedure Check_At_Most_N_Arguments (N : Nat);
-- Check there are no more than N arguments present
+ procedure Check_Component (Comp : Node_Id);
+ -- Examine Unchecked_Union component for correct use of per-object
+ -- constrained subtypes.
+
procedure Check_Duplicated_Export_Name (Nam : Node_Id);
-- Nam is an N_String_Literal node containing the external name set
-- by an Import or Export pragma (or extended Import or Export pragma).
-- and to library level instantiations), and they are simply ignored,
-- which is implemented by rewriting them as null statements.
+ procedure Check_Variant (Variant : Node_Id);
+ -- Check Unchecked_Union variant for lack of nested variants and
+ -- presence of at least one component.
+
procedure Error_Pragma (Msg : String);
pragma No_Return (Error_Pragma);
-- Outputs error message for current pragma. The message contains an %
end if;
end Check_At_Most_N_Arguments;
+ ---------------------
+ -- Check_Component --
+ ---------------------
+
+ procedure Check_Component (Comp : Node_Id) is
+ begin
+ if Nkind (Comp) = N_Component_Declaration then
+ declare
+ Sindic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (Comp));
+
+ begin
+ if Nkind (Sindic) = N_Subtype_Indication then
+
+ -- Ada 2005 (AI-216): If a component subtype is subject to
+ -- a per-object constraint, then the component type shall
+ -- be an Unchecked_Union.
+
+ if Has_Per_Object_Constraint (Defining_Identifier (Comp))
+ and then
+ not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
+ then
+ Error_Msg_N ("component subtype subject to per-object" &
+ " constraint must be an Unchecked_Union", Comp);
+ end if;
+ end if;
+ end;
+ end if;
+ end Check_Component;
+
----------------------------------
-- Check_Duplicated_Export_Name --
----------------------------------
end if;
end Check_Valid_Library_Unit_Pragma;
+ -------------------
+ -- Check_Variant --
+ -------------------
+
+ procedure Check_Variant (Variant : Node_Id) is
+ Clist : constant Node_Id := Component_List (Variant);
+ Comp : Node_Id;
+
+ begin
+ if Present (Variant_Part (Clist)) then
+ Error_Msg_N
+ ("Unchecked_Union may not have nested variants",
+ Variant_Part (Clist));
+ end if;
+
+ if not Is_Non_Empty_List (Component_Items (Clist)) then
+ Error_Msg_N
+ ("Unchecked_Union may not have empty component list",
+ Variant);
+ return;
+ end if;
+
+ Comp := First (Component_Items (Clist));
+ while Present (Comp) loop
+
+ Check_Component (Comp);
+ Next (Comp);
+
+ end loop;
+ end Check_Variant;
+
------------------
-- Error_Pragma --
------------------
Tdef := Type_Definition (Declaration_Node (Typ));
Clist := Component_List (Tdef);
+ Comp := First (Component_Items (Clist));
+ while Present (Comp) loop
+
+ Check_Component (Comp);
+ Next (Comp);
+
+ end loop;
+
if No (Clist) or else No (Variant_Part (Clist)) then
Error_Msg_N
("Unchecked_Union must have variant part",
end if;
Vpart := Variant_Part (Clist);
-
- if Is_Non_Empty_List (Component_Items (Clist)) then
- Error_Msg_N
- ("components before variant not allowed " &
- "in Unchecked_Union",
- First (Component_Items (Clist)));
- end if;
-
Variant := First (Variants (Vpart));
while Present (Variant) loop
- Clist := Component_List (Variant);
-
- if Present (Variant_Part (Clist)) then
- Error_Msg_N
- ("Unchecked_Union may not have nested variants",
- Variant_Part (Clist));
- end if;
-
- if not Is_Non_Empty_List (Component_Items (Clist)) then
- Error_Msg_N
- ("Unchecked_Union may not have empty component list",
- Variant);
- return;
- end if;
-
- Comp := First (Component_Items (Clist));
-
- if Nkind (Comp) = N_Component_Declaration then
-
- if Present (Expression (Comp)) then
- Error_Msg_N
- ("default initialization not allowed " &
- "in Unchecked_Union",
- Expression (Comp));
- end if;
-
- declare
- Sindic : constant Node_Id :=
- Subtype_Indication (Component_Definition (Comp));
-
- begin
- if Nkind (Sindic) = N_Subtype_Indication then
- Check_Static_Constraint (Constraint (Sindic));
- end if;
- end;
- end if;
-
- if Present (Next (Comp)) then
- Error_Msg_N
- ("Unchecked_Union variant can have only one component",
- Next (Comp));
- end if;
+ Check_Variant (Variant);
Next (Variant);
+
end loop;
end if;
return;
else
- if Comes_From_Source (N)
- and then Has_Unchecked_Union (T)
- then
- Error_Msg_N
- ("cannot compare Unchecked_Union values", N);
- end if;
-
Resolve (L, T);
Resolve (R, T);
Check_Unset_Reference (L);
end if;
end if;
- if Comes_From_Source (N)
- and then Has_Unchecked_Union (T)
- then
- Error_Msg_N
- ("cannot compare Unchecked_Union values", N);
- end if;
-
Resolve (L, T);
Resolve (R, T);
Decl : Node_Id;
begin
+ -- Unchecked_Union components do not require component subtypes
+
+ if Is_Unchecked_Union (T) then
+ return Empty;
+ end if;
+
Subt :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
-- because the discriminant is not available. The restrictions on
-- Unchecked_Union are designed to make sure that this is OK.
- elsif Is_Unchecked_Union (Utyp) then
+ elsif Is_Unchecked_Union (Base_Type (Utyp)) then
return Typ;
-- Here for the unconstrained case, we must find actual subtype
function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean;
-- Determines whether Expr is a refeference to a variable or IN OUT
-- mode parameter of the current enclosing subprogram.
+ -- Why are OUT parameters not considered here ???
function Is_Object_Reference (N : Node_Id) return Boolean;
-- Determines if the tree referenced by N represents an object. Both
-- Priority-related Declarations (RM D.1)
- Max_Priority : constant Positive := 30;
- Max_Interrupt_Priority : constant Positive := 31;
-
- subtype Any_Priority is Integer range 0 .. 31;
- subtype Priority is Any_Priority range 0 .. 30;
- subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
- Default_Priority : constant Priority := 15;
+ -- IRIX priorities as defined by realtime(5):
+ --
+ -- 255 is for system-level interrupts
+ -- 240 - 254 are suggested for hard real-time threads
+ -- 200 - 239 are used by system device driver interrupt threads
+ -- 110 - 199 are suggested for interactive real-time applications
+ -- 90 - 109 are used by system daemon threads
+ -- 0 - 89 are suggested for soft real-time applications
+ --
+ -- We don't express the full range of IRIX priorities. For now, we
+ -- handle only the subset for soft real-time applications.
+
+ Max_Priority : constant Positive := 88;
+ Max_Interrupt_Priority : constant Positive := 89;
+
+ subtype Any_Priority is Integer range 0 .. 89;
+ subtype Priority is Any_Priority range 0 .. 88;
+ subtype Interrupt_Priority is Any_Priority range 89 .. 89;
+
+ Default_Priority : constant Priority := 44;
private
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (VxWorks Version x86) --
+-- --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 1.0 / 60.0;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := Low_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ -- 256 is reserved for the VxWorks kernel
+ -- 248 - 255 correspond to hardware interrupt levels 0 .. 7
+ -- 247 is a catchall default "interrupt" priority for signals,
+ -- allowing higher priority than normal tasks, but lower than
+ -- hardware priority levels. Protected Object ceilings can
+ -- override these values.
+ -- 246 is used by the Interrupt_Manager task
+
+ Max_Priority : constant Positive := 245;
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer range 0 .. 255;
+ subtype Priority is Any_Priority range 0 .. 245;
+ subtype Interrupt_Priority is Any_Priority range 246 .. 255;
+
+ Default_Priority : constant Priority := 122;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := False;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := True;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
+end System;
struct stmt_group GTY((chain_next ("%h.previous"))) {
struct stmt_group *previous; /* Previous code group. */
+ struct stmt_group *global; /* Global code group from the level. */
tree stmt_list; /* List of statements for this code group. */
tree block; /* BLOCK for this code group, if any. */
tree cleanups; /* Cleanups for this code group, if any. */
};
static GTY(()) struct stmt_group *current_stmt_group;
-static struct stmt_group *global_stmt_group;
/* List of unused struct stmt_group nodes. */
static GTY((deletable)) struct stmt_group *stmt_group_free_list;
+/* A structure used to record information on elaboration procedures
+ we've made and need to process.
+
+ ??? gnat_node should be Node_Id, but gengtype gets confused. */
+
+struct elab_info GTY((chain_next ("%h.next"))) {
+ struct elab_info *next; /* Pointer to next in chain. */
+ tree elab_proc; /* Elaboration procedure. */
+ int gnat_node; /* The N_Compilation_Unit. */
+};
+
+static GTY(()) struct elab_info *elab_info_list;
+
/* Free list of TREE_LIST nodes used for stacks. */
static GTY((deletable)) tree gnu_stack_free_list;
handler. Not used in the zero-cost case. */
static GTY(()) tree gnu_except_ptr_stack;
+/* List of TREE_LIST nodes used to store the current elaboration procedure
+ decl. TREE_VALUE is the decl. */
+static GTY(()) tree gnu_elab_proc_stack;
+
/* Variable that stores a list of labels to be used as a goto target instead of
a return in some functions. See processing for N_Subprogram_Body. */
static GTY(()) tree gnu_return_label_stack;
TREE_VALUE of each entry is the label at the end of the switch. */
static GTY(()) tree gnu_switch_label_stack;
-/* The FUNCTION_DECL for the elaboration procedure for the main unit. */
-static GTY(()) tree gnu_elab_proc_decl;
-
/* Map GNAT tree codes to GCC tree codes for simple expressions. */
static enum tree_code gnu_codes[Number_Node_Kinds];
/* Current node being treated, in case abort called. */
Node_Id error_gnat_node;
+static void Compilation_Unit_to_gnu (Node_Id);
static void record_code_position (Node_Id);
static void insert_code_for (Node_Id);
static void start_stmt_group (void);
static tree pos_to_constructor (Node_Id, tree, Entity_Id);
static tree maybe_implicit_deref (tree);
static tree gnat_stabilize_reference_1 (tree, bool);
-static bool build_unit_elab (void);
static void annotate_with_node (tree, Node_Id);
/* Constants for +0.5 and -0.5 for float-to-integer rounding. */
Entity_Id standard_long_long_float, Entity_Id standard_exception_type,
Int gigi_operating_mode)
{
- bool body_p;
- Entity_Id gnat_unit_entity;
tree gnu_standard_long_long_float;
tree gnu_standard_exception_type;
+ struct elab_info *info;
max_gnat_nodes = max_gnat_node;
number_names = number_name;
if (Exception_Mechanism == GCC_ZCX)
gnat_init_gcc_eh ();
- /* Make the decl for the elaboration procedure. */
- body_p = (Defining_Entity (Unit (gnat_root)),
- Nkind (Unit (gnat_root)) == N_Package_Body
- || Nkind (Unit (gnat_root)) == N_Subprogram_Body);
- gnat_unit_entity = Defining_Entity (Unit (gnat_root));
-
- gnu_elab_proc_decl
- = create_subprog_decl
- (create_concat_name (gnat_unit_entity,
- body_p ? "elabb" : "elabs"),
- NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
- gnat_unit_entity);
-
- DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
- allocate_struct_function (gnu_elab_proc_decl);
- Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
- cfun = 0;
-
- /* For a body, first process the spec if there is one. */
- if (Nkind (Unit (gnat_root)) == N_Package_Body
- || (Nkind (Unit (gnat_root)) == N_Subprogram_Body
- && !Acts_As_Spec (gnat_root)))
- add_stmt (gnat_to_gnu (Library_Unit (gnat_root)));
+ if (Nkind (gnat_root) != N_Compilation_Unit)
+ abort ();
- process_inlined_subprograms (gnat_root);
+ Compilation_Unit_to_gnu (gnat_root);
- if (type_annotate_only)
+ /* Now see if we have any elaboration procedures to deal with. */
+ for (info = elab_info_list; info; info = info->next)
{
- elaborate_all_entities (gnat_root);
-
- if (Nkind (Unit (gnat_root)) == N_Subprogram_Declaration
- || Nkind (Unit (gnat_root)) == N_Generic_Package_Declaration
- || Nkind (Unit (gnat_root)) == N_Generic_Subprogram_Declaration)
- return;
+ tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
+ tree gnu_stmts;
+
+ /* Mark everything we have as not visited. */
+ walk_tree_without_duplicates (&gnu_body, mark_unvisited, NULL);
+
+ /* Set the current function to be the elaboration procedure and gimplify
+ what we have. */
+ current_function_decl = info->elab_proc;
+ gimplify_body (&gnu_body, info->elab_proc);
+
+ /* We should have a BIND_EXPR, but it may or may not have any statements
+ in it. If it doesn't have any, we have nothing to do. */
+ gnu_stmts = gnu_body;
+ if (TREE_CODE (gnu_stmts) == BIND_EXPR)
+ gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
+
+ /* If there are no statements, there is no elaboration code. */
+ if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
+ Set_Has_No_Elaboration_Code (info->gnat_node, 1);
+ else
+ {
+ /* Otherwise, compile the function. Note that we'll be gimplifying
+ it twice, but that's fine for the nodes we use. */
+ begin_subprog_body (info->elab_proc);
+ end_subprog_body (gnu_body);
+ }
}
-
- process_decls (Declarations (Aux_Decls_Node (gnat_root)), Empty, Empty,
- true, true);
- add_stmt (gnat_to_gnu (Unit (gnat_root)));
-
- /* Process any pragmas and actions following the unit. */
- add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_root)));
- add_stmt_list (Actions (Aux_Decls_Node (gnat_root)));
-
- /* Generate elaboration code for this unit, if necessary, and say whether
- we did or not. */
- Set_Has_No_Elaboration_Code (gnat_root, build_unit_elab ());
}
\f
/* Perform initializations for this module. */
init_code_table ();
start_stmt_group ();
- global_stmt_group = current_stmt_group;
+ current_stmt_group->global = current_stmt_group;
/* Enable GNAT stack checking method if needed */
if (!Stack_Check_Probes_On_Target)
end_stmt_group ());
}
\f
+/* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
+
+static void
+Compilation_Unit_to_gnu (Node_Id gnat_node)
+{
+ /* Make the decl for the elaboration procedure. */
+ bool body_p = (Defining_Entity (Unit (gnat_node)),
+ Nkind (Unit (gnat_node)) == N_Package_Body
+ || Nkind (Unit (gnat_node)) == N_Subprogram_Body);
+ Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
+ tree gnu_elab_proc_decl
+ = create_subprog_decl
+ (create_concat_name (gnat_unit_entity,
+ body_p ? "elabb" : "elabs"),
+ NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
+ gnat_unit_entity);
+ struct elab_info *info;
+
+ push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
+
+ DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
+ allocate_struct_function (gnu_elab_proc_decl);
+ Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
+ cfun = 0;
+
+ /* For a body, first process the spec if there is one. */
+ if (Nkind (Unit (gnat_node)) == N_Package_Body
+ || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
+ && !Acts_As_Spec (gnat_node)))
+ add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
+
+ process_inlined_subprograms (gnat_node);
+
+ if (type_annotate_only)
+ {
+ elaborate_all_entities (gnat_node);
+
+ if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
+ || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
+ || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
+ return;
+ }
+
+ process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
+ true, true);
+ add_stmt (gnat_to_gnu (Unit (gnat_node)));
+
+ /* Process any pragmas and actions following the unit. */
+ add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
+ add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
+
+ /* Save away what we've made so far and record this potential elaboration
+ procedure. */
+ info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info));
+ set_current_block_context (gnu_elab_proc_decl);
+ gnat_poplevel ();
+ DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
+ info->next = elab_info_list;
+ info->elab_proc = gnu_elab_proc_decl;
+ info->gnat_node = gnat_node;
+ elab_info_list = info;
+
+ /* Generate elaboration code for this unit, if necessary, and say whether
+ we did or not. */
+ pop_stack (&gnu_elab_proc_stack);
+}
+\f
/* This function is the driver of the GNAT to GCC tree transformation
process. It is the entry point of the tree transformer. GNAT_NODE is the
root of some GNAT tree. Return the root of the corresponding GCC tree.
|| Nkind (gnat_node) == N_Raise_Program_Error)
&& (Ekind (Etype (gnat_node)) == E_Void))))
{
- current_function_decl = gnu_elab_proc_decl;
+ current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
start_stmt_group ();
gnat_pushlevel ();
went_into_elab_proc = true;
/* This is not called for the main unit, which is handled in function
gigi above. */
start_stmt_group ();
+ current_stmt_group->global = current_stmt_group;
+ gnat_pushlevel ();
- /* For a body, first process the spec if there is one. */
- if (Nkind (Unit (gnat_node)) == N_Package_Body
- || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
- && !Acts_As_Spec (gnat_node)))
- add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
-
- process_inlined_subprograms (gnat_node);
- process_decls (Declarations (Aux_Decls_Node (gnat_node)),
- Empty, Empty, true, true);
- add_stmt (gnat_to_gnu (Unit (gnat_node)));
-
- /* Process any pragmas and actions following the unit. */
- add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
- add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
-
- Set_Has_No_Elaboration_Code (gnat_node, 1);
- gnu_result = end_stmt_group ();
+ Compilation_Unit_to_gnu (gnat_node);
+ gnu_result = alloc_stmt_list ();
break;
case N_Subprogram_Body_Stub:
group->previous = current_stmt_group;
group->stmt_list = group->block = group->cleanups = NULL_TREE;
+ group->global = current_stmt_group ? current_stmt_group->global : NULL;
current_stmt_group = group;
}
return;
if (global_bindings_p ())
- current_stmt_group = global_stmt_group;
+ current_stmt_group = current_stmt_group->global;
add_stmt_with_node (build (DECL_EXPR, void_type_node, gnu_decl),
gnat_entity);
/* Generate GIMPLE in place for the expression at *EXPR_P. */
int
-gnat_gimplify_expr (tree *expr_p, tree *pre_p ATTRIBUTE_UNUSED, tree *post_p)
+gnat_gimplify_expr (tree *expr_p, tree *pre_p, tree *post_p ATTRIBUTE_UNUSED)
{
tree expr = *expr_p;
TREE_NO_WARNING (*expr_p) = 1;
}
- append_to_statement_list (TREE_OPERAND (expr, 0), post_p);
+ append_to_statement_list (TREE_OPERAND (expr, 0), pre_p);
return GS_OK;
case UNCONSTRAINED_ARRAY_REF:
return result;
}
\f
-/* Take care of building the elaboration procedure for the main unit.
-
- Return true if we didn't need an elaboration function, false otherwise. */
-
-static bool
-build_unit_elab ()
-{
- tree body, stmts;
-
- /* Mark everything we have as not visited. */
- walk_tree_without_duplicates (¤t_stmt_group->stmt_list,
- mark_unvisited, NULL);
-
- /* Set the current function to be the elaboration procedure, pop our
- binding level, end our statement group, and gimplify what we have. */
- set_current_block_context (gnu_elab_proc_decl);
- gnat_poplevel ();
- body = end_stmt_group ();
- current_function_decl = gnu_elab_proc_decl;
- gimplify_body (&body, gnu_elab_proc_decl);
-
- /* We should have a BIND_EXPR, but it may or may not have any statements
- in it. If it doesn't have any, we have nothing to do. */
- stmts = body;
- if (TREE_CODE (stmts) == BIND_EXPR)
- stmts = BIND_EXPR_BODY (stmts);
-
- /* If there are no statements, we have nothing to do. */
- if (!stmts || !STATEMENT_LIST_HEAD (stmts))
- return true;
-
- /* Otherwise, compile the function. Note that we'll be gimplifying
- it twice, but that's fine for the nodes we use. */
- begin_subprog_body (gnu_elab_proc_decl);
- end_subprog_body (body);
-
- return false;
-}
-\f
extern char *__gnat_to_canonical_file_spec (char *);
/* Convert Sloc into *LOCUS (a location_t). Return true if this Sloc
int
global_bindings_p (void)
{
- return (force_global || !current_binding_level
- || !current_binding_level->chain ? -1 : 0);
+ return ((force_global || !current_function_decl) ? -1 : 0);
}
/* Enter a new binding level. */
TYPE_NAME (TREE_TYPE (decl)) = decl;
if (TREE_CODE (decl) != CONST_DECL)
- rest_of_decl_compilation (decl, NULL, global_bindings_p (), 0);
+ rest_of_decl_compilation (decl, global_bindings_p (), 0);
}
\f
/* Do little here. Set up the standard declarations later after the
-- --
------------------------------------------------------------------------------
--- This package is part of the GNAT driver. It contains a procedure
--- VMS_Conversion to convert the command line in VMS form to the equivalent
--- command line with switches for the GNAT tools that the GNAT driver will
--- invoke.
---
+-- This package is part of the GNAT driver. It contains the procedure
+-- VMS_Conversion to convert a VMS command line to the equivalent command
+-- line with switches for the GNAT tools that the GNAT driver will invoke.
-- The qualifier declarations are contained in package VMS_Data.
with Table;
-- Set true if /? switch causes display of generated command (on VMS)
-------------------
- -- COMMAND TABLE --
+ -- Command Table --
-------------------
-- The command table contains an entry for each command recognized by
-- A parameter is defined as a whitespace bounded string, not begining
-- with a slash. (But see note under FILES_OR_WILDCARD).
(File,
- -- A required file or directory parameter.
+ -- A required file or directory parameter
Optional_File,
- -- An optional file or directory parameter.
+ -- An optional file or directory parameter
Other_As_Is,
-- A parameter that's passed through as is (not canonicalized)
type Parameter_Ref is access all Parameter_Array;
type Command_Type is
- (Bind, Chop, Clean, Compile, Elim, Find, Krunch, Library, Link, List,
- Make, Metric, Name, Preprocess, Pretty, Setup, Shared, Stub, Xref,
+ (Bind,
+ Chop,
+ Clean,
+ Compile,
+ Elim,
+ Find,
+ Krunch,
+ Library,
+ Link,
+ List,
+ Make,
+ Metric,
+ Name,
+ Preprocess,
+ Pretty,
+ Setup,
+ Shared,
+ Stub,
+ Xref,
Undefined);
type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
- -- Alternate command libel for non VMS system
+ -- Alternate command label for non VMS system use
Corresponding_To : constant array (Alternate_Command) of Command_Type :=
(Comp => Compile,
end record;
-------------------------
- -- INTERNAL STRUCTURES --
+ -- Internal Structures --
-------------------------
-- The switches and commands are defined by strings in the previous
subtype Switch_Item is Item (Id_Switch);
subtype Option_Item is Item (Id_Option);
- ------------------
- -- SWITCH TABLE --
- ------------------
+ -------------------
+ -- Switch Tables --
+ -------------------
-- The switch tables contain an entry for each switch recognized by the
-- command processor. It is initialized by procedure Initialize.
-- output. A line containing this escape sequence may not also contain
-- a ^alpha^beta^ sequence.
--- Recognize @ifset and @ifclear (this is because we have menu problems
--- if we let makeinfo handle the ifset/ifclear pairs
+-- Process @ifset and @ifclear for the target flags (unw, vms);
+-- this is because we have menu problems if we let makeinfo handle
+-- these ifset/ifclear pairs.
+-- Note: @ifset/@ifclear commands for the edition flags (FSFEDITION,
+-- PROEDITION, ACADEMICEDITION) are passed through unchanged
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Strings; use Ada.Strings;
procedure Warning
(Input : Input_File;
Message : String);
- -- Like Error, but just print a warning message.
+ -- Like Error, but just print a warning message
Dictionary_File : aliased Input_File;
procedure Read_Dictionary_File;
-- It contains the Texinfo source code. Process_Source_File
-- performs the necessary replacements.
- type Target_Type is (UNW, VMS);
+ type Flag_Type is (UNW, VMS, FSFEDITION, PROEDITION, ACADEMICEDITION);
+ -- The flags permitted in @ifset or @ifclear commands:
+ --
+ -- Targets for preprocessing
+ -- UNW (Unix and Windows) or VMS
+ --
+ -- Editions of the manual
+ -- FSFEDITION, PROEDITION, or ACADEMICEDITION
+ --
+ -- Conditional commands for target are processed by xgnatugn
+ --
+ -- Conditional commands for edition are passed through unchanged
+
+ subtype Target_Type is Flag_Type range UNW .. VMS;
+ subtype Edition_Type is Flag_Type range FSFEDITION .. ACADEMICEDITION;
+
Target : Target_Type;
- -- The target for which preprocessing is performed:
- -- UNW (Unix and Windows) or VMS
- -- The Target variable is initialized using the command line.
+ -- The Target variable is initialized using the command line
Valid_Characters : constant Character_Set
:= To_Set (Span => (' ', '~'));
-- execution terminates with a Fatal_Line_Length exception.
VMS_Escape_Character : constant Character := '^';
- -- The character used to mark VMS alternatives (^alpha^beta^).
+ -- The character used to mark VMS alternatives (^alpha^beta^)
Extensions : GNAT.Spitbol.Table_VString.Table (20);
procedure Initialize_Extensions;
-- Target.
function In_VMS_Section return Boolean;
- -- Returns True if in an "@ifset vms" section.
+ -- Returns True if in an "@ifset vms" section
procedure Check_No_Pending_Conditional;
-- Checks that all preprocessing directives have been properly matched by
type Conditional_Context is record
Starting_Line : Positive;
Cond : Conditional;
- Flag : Target_Type;
+ Flag : Flag_Type;
Excluding : Boolean;
end record;
array (1 .. Conditional_Stack_Depth) of Conditional_Context;
Conditional_TOS : Natural := 0;
- -- Pointer to the Top Of Stack for Conditional_Stack.
+ -- Pointer to the Top Of Stack for Conditional_Stack
-----------
-- Usage --
procedure Usage is
begin
Put_Line (Standard_Error,
- "usage: xgnatug TARGET SOURCE DICTIONARY [OUTFILE [WARNINGS]]");
+ "usage: xgnatugn TARGET SOURCE DICTIONARY [OUTFILE [WARNINGS]]");
New_Line;
Put_Line (Standard_Error, "TARGET is one of:");
-----------
procedure Error
- (Input : Input_File;
- Message : String)
+ (Input : Input_File;
+ Message : String)
is
begin
Error (Input, 0, Message);
return;
end if;
- -- ^alpha^beta^, the VMS_Alternative case.
+ -- ^alpha^beta^, the VMS_Alternative case
if Remaining_Line (Remaining_Line'First) = VMS_Escape_Character then
declare
(Line (Token.Span.First .. Token.Span.Last)));
Next_Token;
else
- -- We already have: Word ".", followed by an unknown
- -- token.
+ -- We already have: Word ".", followed by an unknown token
Append (Rewritten_Line, First_Word & '.');
Ifset : constant String := "@ifset ";
Ifclear : constant String := "@ifclear ";
Endsetclear : constant String := "@end ";
- -- Strings to be recognized for conditional processing.
+ -- Strings to be recognized for conditional processing
begin
while not End_Of_File (Source_File.Data) loop
-- directive.
Cond : Conditional;
- -- The kind of the directive.
+ -- The kind of the directive
- Flag : Target_Type;
- -- Its flag.
+ Flag : Flag_Type;
+ -- Its flag
begin
-- If the line starts with @ifset or @ifclear, we try to convert
- -- the following flag to one of our target types. If we fail,
+ -- the following flag to one of our flag types. If we fail,
-- Have_Conditional remains False.
if Line'Length >= Ifset'Length
Trim (Line (Ifset'Length + 1 .. Line'Last), Both);
begin
- Flag := Target_Type'Value (Arg);
-
- if Translate (Target_Type'Image (Flag), Lower_Case_Map)
- /= Arg
- then
- Error (Source_File, "flag has to be lowercase");
- end if;
-
+ Flag := Flag_Type'Value (Arg);
Have_Conditional := True;
+ case Flag is
+ when Target_Type =>
+ if Translate (Target_Type'Image (Flag),
+ Lower_Case_Map)
+ /= Arg
+ then
+ Error (Source_File, "flag has to be lowercase");
+ end if;
+
+ when Edition_Type =>
+ null;
+ end case;
exception
when Constraint_Error =>
Error (Source_File, "unknown flag for '@ifset'");
Trim (Line (Ifclear'Length + 1 .. Line'Last), Both);
begin
- Flag := Target_Type'Value (Arg);
- if Translate (Target_Type'Image (Flag), Lower_Case_Map)
- /= Arg
- then
- Error (Source_File, "flag has to be lowercase");
- end if;
-
+ Flag := Flag_Type'Value (Arg);
Have_Conditional := True;
+ case Flag is
+ when Target_Type =>
+ if Translate (Target_Type'Image (Flag),
+ Lower_Case_Map)
+ /= Arg
+ then
+ Error (Source_File, "flag has to be lowercase");
+ end if;
+
+ when Edition_Type =>
+ null;
+ end case;
exception
when Constraint_Error =>
Error (Source_File, "unknown flag for '@ifclear'");
end;
end if;
- if Have_Conditional then
+ if Have_Conditional and (Flag in Target_Type) then
-- We create a new conditional context and suppress the
-- directive in the output.
elsif Line'Length >= Endsetclear'Length
and then Line (1 .. Endsetclear'Length) = Endsetclear
+ and then (Flag in Target_Type)
then
-- The '@end ifset'/'@end ifclear' case is handled here. We
-- have to pop the conditional context.
end;
end if; -- Have_Conditional
- if not Have_Conditional then
+ if (not Have_Conditional) or (Flag in Edition_Type) then
-- The ordinary case.
end loop;
end Check_No_Pending_Conditional;
- ------------------
- -- Main Program --
- ------------------
+-- Start of processing for Xgnatugn
Valid_Command_Line : Boolean;
Output_File_Name : VString;
begin
Initialize_Extensions;
-
Valid_Command_Line := Argument_Count in 3 .. 5;
- -- First argument: Target.
+ -- First argument: Target
if Valid_Command_Line then
begin
- Target := Target_Type'Value (Argument (1));
+ Target := Flag_Type'Value (Argument (1));
+
+ if Target not in Target_Type then
+ Valid_Command_Line := False;
+ end if;
exception
when Constraint_Error =>
end;
end if;
- -- Second argument: Source_File.
+ -- Second argument: Source_File
if Valid_Command_Line then
begin
end;
end if;
- -- Third argument: Dictionary_File.
+ -- Third argument: Dictionary_File
if Valid_Command_Line then
begin
end;
end if;
- -- Fourth argument: Output_File.
+ -- Fourth argument: Output_File
if Valid_Command_Line then
if Argument_Count in 4 .. 5 then
Read_Dictionary_File;
Close (Dictionary_File.Data);
- -- Main processing starts here.
+ -- Main processing starts here
Process_Source_File;
Close (Output_File);
projects / gcc.git / commitdiff