1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- C O N T R A C T S --
9 -- Copyright (C) 2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Exp_Prag
; use Exp_Prag
;
32 with Exp_Tss
; use Exp_Tss
;
33 with Exp_Util
; use Exp_Util
;
34 with Namet
; use Namet
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
39 with Sem_Aux
; use Sem_Aux
;
40 with Sem_Ch6
; use Sem_Ch6
;
41 with Sem_Ch8
; use Sem_Ch8
;
42 with Sem_Ch12
; use Sem_Ch12
;
43 with Sem_Disp
; use Sem_Disp
;
44 with Sem_Prag
; use Sem_Prag
;
45 with Sem_Util
; use Sem_Util
;
46 with Sinfo
; use Sinfo
;
47 with Snames
; use Snames
;
48 with Stringt
; use Stringt
;
49 with Tbuild
; use Tbuild
;
51 package body Contracts
is
53 procedure Analyze_Contracts
56 Freeze_Id
: Entity_Id
);
57 -- Subsidiary to the one parameter version of Analyze_Contracts and routine
58 -- Analyze_Previous_Constracts. Analyze the contracts of all constructs in
59 -- the list L. If Freeze_Nod is set, then the analysis stops when the node
60 -- is reached. Freeze_Id is the entity of some related context which caused
61 -- freezing up to node Freeze_Nod.
63 procedure Expand_Subprogram_Contract
(Body_Id
: Entity_Id
);
64 -- Expand the contracts of a subprogram body and its correspoding spec (if
65 -- any). This routine processes all [refined] pre- and postconditions as
66 -- well as Contract_Cases, invariants and predicates. Body_Id denotes the
67 -- entity of the subprogram body.
69 -----------------------
70 -- Add_Contract_Item --
71 -----------------------
73 procedure Add_Contract_Item
(Prag
: Node_Id
; Id
: Entity_Id
) is
74 Items
: Node_Id
:= Contract
(Id
);
76 procedure Add_Classification
;
77 -- Prepend Prag to the list of classifications
79 procedure Add_Contract_Test_Case
;
80 -- Prepend Prag to the list of contract and test cases
82 procedure Add_Pre_Post_Condition
;
83 -- Prepend Prag to the list of pre- and postconditions
85 ------------------------
86 -- Add_Classification --
87 ------------------------
89 procedure Add_Classification
is
91 Set_Next_Pragma
(Prag
, Classifications
(Items
));
92 Set_Classifications
(Items
, Prag
);
93 end Add_Classification
;
95 ----------------------------
96 -- Add_Contract_Test_Case --
97 ----------------------------
99 procedure Add_Contract_Test_Case
is
101 Set_Next_Pragma
(Prag
, Contract_Test_Cases
(Items
));
102 Set_Contract_Test_Cases
(Items
, Prag
);
103 end Add_Contract_Test_Case
;
105 ----------------------------
106 -- Add_Pre_Post_Condition --
107 ----------------------------
109 procedure Add_Pre_Post_Condition
is
111 Set_Next_Pragma
(Prag
, Pre_Post_Conditions
(Items
));
112 Set_Pre_Post_Conditions
(Items
, Prag
);
113 end Add_Pre_Post_Condition
;
119 -- Start of processing for Add_Contract_Item
122 -- A contract must contain only pragmas
124 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
125 Prag_Nam
:= Pragma_Name
(Prag
);
127 -- Create a new contract when adding the first item
130 Items
:= Make_Contract
(Sloc
(Id
));
131 Set_Contract
(Id
, Items
);
134 -- Constants, the applicable pragmas are:
137 if Ekind
(Id
) = E_Constant
then
138 if Prag_Nam
= Name_Part_Of
then
141 -- The pragma is not a proper contract item
147 -- Entry bodies, the applicable pragmas are:
152 elsif Is_Entry_Body
(Id
) then
153 if Nam_In
(Prag_Nam
, Name_Refined_Depends
, Name_Refined_Global
) then
156 elsif Prag_Nam
= Name_Refined_Post
then
157 Add_Pre_Post_Condition
;
159 -- The pragma is not a proper contract item
165 -- Entry or subprogram declarations, the applicable pragmas are:
169 -- Extensions_Visible
177 elsif Is_Entry_Declaration
(Id
)
178 or else Ekind_In
(Id
, E_Function
,
183 if Nam_In
(Prag_Nam
, Name_Attach_Handler
, Name_Interrupt_Handler
)
184 and then Ekind_In
(Id
, E_Generic_Procedure
, E_Procedure
)
188 elsif Nam_In
(Prag_Nam
, Name_Depends
,
189 Name_Extensions_Visible
,
194 elsif Prag_Nam
= Name_Volatile_Function
195 and then Ekind_In
(Id
, E_Function
, E_Generic_Function
)
199 elsif Nam_In
(Prag_Nam
, Name_Contract_Cases
, Name_Test_Case
) then
200 Add_Contract_Test_Case
;
202 elsif Nam_In
(Prag_Nam
, Name_Postcondition
, Name_Precondition
) then
203 Add_Pre_Post_Condition
;
205 -- The pragma is not a proper contract item
211 -- Packages or instantiations, the applicable pragmas are:
215 -- Part_Of (instantiation only)
217 elsif Ekind_In
(Id
, E_Generic_Package
, E_Package
) then
218 if Nam_In
(Prag_Nam
, Name_Abstract_State
,
219 Name_Initial_Condition
,
224 -- Indicator Part_Of must be associated with a package instantiation
226 elsif Prag_Nam
= Name_Part_Of
and then Is_Generic_Instance
(Id
) then
229 -- The pragma is not a proper contract item
235 -- Package bodies, the applicable pragmas are:
238 elsif Ekind
(Id
) = E_Package_Body
then
239 if Prag_Nam
= Name_Refined_State
then
242 -- The pragma is not a proper contract item
248 -- Protected units, the applicable pragmas are:
251 elsif Ekind
(Id
) = E_Protected_Type
then
252 if Prag_Nam
= Name_Part_Of
then
255 -- The pragma is not a proper contract item
261 -- Subprogram bodies, the applicable pragmas are:
268 elsif Ekind
(Id
) = E_Subprogram_Body
then
269 if Nam_In
(Prag_Nam
, Name_Refined_Depends
, Name_Refined_Global
) then
272 elsif Nam_In
(Prag_Nam
, Name_Postcondition
,
276 Add_Pre_Post_Condition
;
278 -- The pragma is not a proper contract item
284 -- Task bodies, the applicable pragmas are:
288 elsif Ekind
(Id
) = E_Task_Body
then
289 if Nam_In
(Prag_Nam
, Name_Refined_Depends
, Name_Refined_Global
) then
292 -- The pragma is not a proper contract item
298 -- Task units, the applicable pragmas are:
303 elsif Ekind
(Id
) = E_Task_Type
then
304 if Nam_In
(Prag_Nam
, Name_Depends
, Name_Global
, Name_Part_Of
) then
307 -- The pragma is not a proper contract item
313 -- Variables, the applicable pragmas are:
316 -- Constant_After_Elaboration
323 elsif Ekind
(Id
) = E_Variable
then
324 if Nam_In
(Prag_Nam
, Name_Async_Readers
,
326 Name_Constant_After_Elaboration
,
328 Name_Effective_Reads
,
329 Name_Effective_Writes
,
335 -- The pragma is not a proper contract item
341 end Add_Contract_Item
;
343 -----------------------
344 -- Analyze_Contracts --
345 -----------------------
347 procedure Analyze_Contracts
(L
: List_Id
) is
349 Analyze_Contracts
(L
, Freeze_Nod
=> Empty
, Freeze_Id
=> Empty
);
350 end Analyze_Contracts
;
352 procedure Analyze_Contracts
354 Freeze_Nod
: Node_Id
;
355 Freeze_Id
: Entity_Id
)
361 while Present
(Decl
) loop
363 -- The caller requests that the traversal stops at a particular node
364 -- that causes contract "freezing".
366 if Present
(Freeze_Nod
) and then Decl
= Freeze_Nod
then
370 -- Entry or subprogram declarations
372 if Nkind_In
(Decl
, N_Abstract_Subprogram_Declaration
,
374 N_Generic_Subprogram_Declaration
,
375 N_Subprogram_Declaration
)
377 Analyze_Entry_Or_Subprogram_Contract
378 (Subp_Id
=> Defining_Entity
(Decl
),
379 Freeze_Id
=> Freeze_Id
);
381 -- Entry or subprogram bodies
383 elsif Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
384 Analyze_Entry_Or_Subprogram_Body_Contract
(Defining_Entity
(Decl
));
388 elsif Nkind
(Decl
) = N_Object_Declaration
then
389 Analyze_Object_Contract
390 (Obj_Id
=> Defining_Entity
(Decl
),
391 Freeze_Id
=> Freeze_Id
);
395 elsif Nkind_In
(Decl
, N_Protected_Type_Declaration
,
396 N_Single_Protected_Declaration
)
398 Analyze_Protected_Contract
(Defining_Entity
(Decl
));
400 -- Subprogram body stubs
402 elsif Nkind
(Decl
) = N_Subprogram_Body_Stub
then
403 Analyze_Subprogram_Body_Stub_Contract
(Defining_Entity
(Decl
));
407 elsif Nkind_In
(Decl
, N_Single_Task_Declaration
,
408 N_Task_Type_Declaration
)
410 Analyze_Task_Contract
(Defining_Entity
(Decl
));
415 end Analyze_Contracts
;
417 -----------------------------------------------
418 -- Analyze_Entry_Or_Subprogram_Body_Contract --
419 -----------------------------------------------
421 procedure Analyze_Entry_Or_Subprogram_Body_Contract
(Body_Id
: Entity_Id
) is
422 Body_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Body_Id
);
423 Items
: constant Node_Id
:= Contract
(Body_Id
);
424 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Body_Decl
);
425 Mode
: SPARK_Mode_Type
;
428 -- When a subprogram body declaration is illegal, its defining entity is
429 -- left unanalyzed. There is nothing left to do in this case because the
430 -- body lacks a contract, or even a proper Ekind.
432 if Ekind
(Body_Id
) = E_Void
then
435 -- Do not analyze a contract multiple times
437 elsif Present
(Items
) then
438 if Analyzed
(Items
) then
441 Set_Analyzed
(Items
);
445 -- Due to the timing of contract analysis, delayed pragmas may be
446 -- subject to the wrong SPARK_Mode, usually that of the enclosing
447 -- context. To remedy this, restore the original SPARK_Mode of the
448 -- related subprogram body.
450 Save_SPARK_Mode_And_Set
(Body_Id
, Mode
);
452 -- Ensure that the contract cases or postconditions mention 'Result or
453 -- define a post-state.
455 Check_Result_And_Post_State
(Body_Id
);
457 -- A stand-alone nonvolatile function body cannot have an effectively
458 -- volatile formal parameter or return type (SPARK RM 7.1.3(9)). This
459 -- check is relevant only when SPARK_Mode is on, as it is not a standard
460 -- legality rule. The check is performed here because Volatile_Function
461 -- is processed after the analysis of the related subprogram body.
464 and then Ekind_In
(Body_Id
, E_Function
, E_Generic_Function
)
465 and then not Is_Volatile_Function
(Body_Id
)
467 Check_Nonvolatile_Function_Profile
(Body_Id
);
470 -- Restore the SPARK_Mode of the enclosing context after all delayed
471 -- pragmas have been analyzed.
473 Restore_SPARK_Mode
(Mode
);
475 -- Capture all global references in a generic subprogram body now that
476 -- the contract has been analyzed.
478 if Is_Generic_Declaration_Or_Body
(Body_Decl
) then
479 Save_Global_References_In_Contract
480 (Templ
=> Original_Node
(Body_Decl
),
484 -- Deal with preconditions, [refined] postconditions, Contract_Cases,
485 -- invariants and predicates associated with body and its spec. Do not
486 -- expand the contract of subprogram body stubs.
488 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
489 Expand_Subprogram_Contract
(Body_Id
);
491 end Analyze_Entry_Or_Subprogram_Body_Contract
;
493 ------------------------------------------
494 -- Analyze_Entry_Or_Subprogram_Contract --
495 ------------------------------------------
497 procedure Analyze_Entry_Or_Subprogram_Contract
498 (Subp_Id
: Entity_Id
;
499 Freeze_Id
: Entity_Id
:= Empty
)
501 Items
: constant Node_Id
:= Contract
(Subp_Id
);
502 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
504 Skip_Assert_Exprs
: constant Boolean :=
505 Ekind_In
(Subp_Id
, E_Entry
, E_Entry_Family
)
506 and then not ASIS_Mode
507 and then not GNATprove_Mode
;
509 Depends
: Node_Id
:= Empty
;
510 Global
: Node_Id
:= Empty
;
511 Mode
: SPARK_Mode_Type
;
516 -- Do not analyze a contract multiple times
518 if Present
(Items
) then
519 if Analyzed
(Items
) then
522 Set_Analyzed
(Items
);
526 -- Due to the timing of contract analysis, delayed pragmas may be
527 -- subject to the wrong SPARK_Mode, usually that of the enclosing
528 -- context. To remedy this, restore the original SPARK_Mode of the
529 -- related subprogram body.
531 Save_SPARK_Mode_And_Set
(Subp_Id
, Mode
);
533 -- All subprograms carry a contract, but for some it is not significant
534 -- and should not be processed.
536 if not Has_Significant_Contract
(Subp_Id
) then
539 elsif Present
(Items
) then
541 -- Do not analyze the pre/postconditions of an entry declaration
542 -- unless annotating the original tree for ASIS or GNATprove. The
543 -- real analysis occurs when the pre/postconditons are relocated to
544 -- the contract wrapper procedure (see Build_Contract_Wrapper).
546 if Skip_Assert_Exprs
then
549 -- Otherwise analyze the pre/postconditions
552 Prag
:= Pre_Post_Conditions
(Items
);
553 while Present
(Prag
) loop
554 Analyze_Pre_Post_Condition_In_Decl_Part
(Prag
, Freeze_Id
);
555 Prag
:= Next_Pragma
(Prag
);
559 -- Analyze contract-cases and test-cases
561 Prag
:= Contract_Test_Cases
(Items
);
562 while Present
(Prag
) loop
563 Prag_Nam
:= Pragma_Name
(Prag
);
565 if Prag_Nam
= Name_Contract_Cases
then
567 -- Do not analyze the contract cases of an entry declaration
568 -- unless annotating the original tree for ASIS or GNATprove.
569 -- The real analysis occurs when the contract cases are moved
570 -- to the contract wrapper procedure (Build_Contract_Wrapper).
572 if Skip_Assert_Exprs
then
575 -- Otherwise analyze the contract cases
578 Analyze_Contract_Cases_In_Decl_Part
(Prag
, Freeze_Id
);
581 pragma Assert
(Prag_Nam
= Name_Test_Case
);
582 Analyze_Test_Case_In_Decl_Part
(Prag
);
585 Prag
:= Next_Pragma
(Prag
);
588 -- Analyze classification pragmas
590 Prag
:= Classifications
(Items
);
591 while Present
(Prag
) loop
592 Prag_Nam
:= Pragma_Name
(Prag
);
594 if Prag_Nam
= Name_Depends
then
597 elsif Prag_Nam
= Name_Global
then
601 Prag
:= Next_Pragma
(Prag
);
604 -- Analyze Global first, as Depends may mention items classified in
605 -- the global categorization.
607 if Present
(Global
) then
608 Analyze_Global_In_Decl_Part
(Global
);
611 -- Depends must be analyzed after Global in order to see the modes of
614 if Present
(Depends
) then
615 Analyze_Depends_In_Decl_Part
(Depends
);
618 -- Ensure that the contract cases or postconditions mention 'Result
619 -- or define a post-state.
621 Check_Result_And_Post_State
(Subp_Id
);
624 -- A nonvolatile function cannot have an effectively volatile formal
625 -- parameter or return type (SPARK RM 7.1.3(9)). This check is relevant
626 -- only when SPARK_Mode is on, as it is not a standard legality rule.
627 -- The check is performed here because pragma Volatile_Function is
628 -- processed after the analysis of the related subprogram declaration.
631 and then Ekind_In
(Subp_Id
, E_Function
, E_Generic_Function
)
632 and then not Is_Volatile_Function
(Subp_Id
)
634 Check_Nonvolatile_Function_Profile
(Subp_Id
);
637 -- Restore the SPARK_Mode of the enclosing context after all delayed
638 -- pragmas have been analyzed.
640 Restore_SPARK_Mode
(Mode
);
642 -- Capture all global references in a generic subprogram now that the
643 -- contract has been analyzed.
645 if Is_Generic_Declaration_Or_Body
(Subp_Decl
) then
646 Save_Global_References_In_Contract
647 (Templ
=> Original_Node
(Subp_Decl
),
650 end Analyze_Entry_Or_Subprogram_Contract
;
652 -----------------------------
653 -- Analyze_Object_Contract --
654 -----------------------------
656 procedure Analyze_Object_Contract
658 Freeze_Id
: Entity_Id
:= Empty
)
660 Obj_Typ
: constant Entity_Id
:= Etype
(Obj_Id
);
661 AR_Val
: Boolean := False;
662 AW_Val
: Boolean := False;
663 Encap_Id
: Entity_Id
;
664 ER_Val
: Boolean := False;
665 EW_Val
: Boolean := False;
667 Mode
: SPARK_Mode_Type
;
670 Restore_Mode
: Boolean := False;
671 Seen
: Boolean := False;
674 -- The loop parameter in an element iterator over a formal container
675 -- is declared with an object declaration, but no contracts apply.
677 if Ekind
(Obj_Id
) = E_Loop_Parameter
then
681 -- Do not analyze a contract multiple times
683 Items
:= Contract
(Obj_Id
);
685 if Present
(Items
) then
686 if Analyzed
(Items
) then
689 Set_Analyzed
(Items
);
693 -- The anonymous object created for a single concurrent type inherits
694 -- the SPARK_Mode from the type. Due to the timing of contract analysis,
695 -- delayed pragmas may be subject to the wrong SPARK_Mode, usually that
696 -- of the enclosing context. To remedy this, restore the original mode
697 -- of the related anonymous object.
699 if Is_Single_Concurrent_Object
(Obj_Id
)
700 and then Present
(SPARK_Pragma
(Obj_Id
))
702 Restore_Mode
:= True;
703 Save_SPARK_Mode_And_Set
(Obj_Id
, Mode
);
706 -- Constant-related checks
708 if Ekind
(Obj_Id
) = E_Constant
then
710 -- Analyze indicator Part_Of
712 Prag
:= Get_Pragma
(Obj_Id
, Pragma_Part_Of
);
714 -- Check whether the lack of indicator Part_Of agrees with the
715 -- placement of the constant with respect to the state space.
718 Check_Missing_Part_Of
(Obj_Id
);
721 -- A constant cannot be effectively volatile (SPARK RM 7.1.3(4)).
722 -- This check is relevant only when SPARK_Mode is on, as it is not
723 -- a standard Ada legality rule. Internally-generated constants that
724 -- map generic formals to actuals in instantiations are allowed to
728 and then Comes_From_Source
(Obj_Id
)
729 and then Is_Effectively_Volatile
(Obj_Id
)
730 and then No
(Corresponding_Generic_Association
(Parent
(Obj_Id
)))
732 Error_Msg_N
("constant cannot be volatile", Obj_Id
);
735 -- Variable-related checks
737 else pragma Assert
(Ekind
(Obj_Id
) = E_Variable
);
739 -- Analyze all external properties
741 Prag
:= Get_Pragma
(Obj_Id
, Pragma_Async_Readers
);
743 if Present
(Prag
) then
744 Analyze_External_Property_In_Decl_Part
(Prag
, AR_Val
);
748 Prag
:= Get_Pragma
(Obj_Id
, Pragma_Async_Writers
);
750 if Present
(Prag
) then
751 Analyze_External_Property_In_Decl_Part
(Prag
, AW_Val
);
755 Prag
:= Get_Pragma
(Obj_Id
, Pragma_Effective_Reads
);
757 if Present
(Prag
) then
758 Analyze_External_Property_In_Decl_Part
(Prag
, ER_Val
);
762 Prag
:= Get_Pragma
(Obj_Id
, Pragma_Effective_Writes
);
764 if Present
(Prag
) then
765 Analyze_External_Property_In_Decl_Part
(Prag
, EW_Val
);
769 -- Verify the mutual interaction of the various external properties
772 Check_External_Properties
(Obj_Id
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
775 -- The anonymous object created for a single concurrent type carries
776 -- pragmas Depends and Globat of the type.
778 if Is_Single_Concurrent_Object
(Obj_Id
) then
780 -- Analyze Global first, as Depends may mention items classified
781 -- in the global categorization.
783 Prag
:= Get_Pragma
(Obj_Id
, Pragma_Global
);
785 if Present
(Prag
) then
786 Analyze_Global_In_Decl_Part
(Prag
);
789 -- Depends must be analyzed after Global in order to see the modes
790 -- of all global items.
792 Prag
:= Get_Pragma
(Obj_Id
, Pragma_Depends
);
794 if Present
(Prag
) then
795 Analyze_Depends_In_Decl_Part
(Prag
);
799 Prag
:= Get_Pragma
(Obj_Id
, Pragma_Part_Of
);
801 -- Analyze indicator Part_Of
803 if Present
(Prag
) then
804 Analyze_Part_Of_In_Decl_Part
(Prag
, Freeze_Id
);
806 -- The variable is a constituent of a single protected/task type
807 -- and behaves as a component of the type. Verify that references
808 -- to the variable occur within the definition or body of the type
811 if Present
(Encapsulating_State
(Obj_Id
))
812 and then Is_Single_Concurrent_Object
813 (Encapsulating_State
(Obj_Id
))
814 and then Present
(Part_Of_References
(Obj_Id
))
816 Ref_Elmt
:= First_Elmt
(Part_Of_References
(Obj_Id
));
817 while Present
(Ref_Elmt
) loop
818 Check_Part_Of_Reference
(Obj_Id
, Node
(Ref_Elmt
));
819 Next_Elmt
(Ref_Elmt
);
823 -- Otherwise check whether the lack of indicator Part_Of agrees with
824 -- the placement of the variable with respect to the state space.
827 Check_Missing_Part_Of
(Obj_Id
);
830 -- The following checks are relevant only when SPARK_Mode is on, as
831 -- they are not standard Ada legality rules. Internally generated
832 -- temporaries are ignored.
834 if SPARK_Mode
= On
and then Comes_From_Source
(Obj_Id
) then
835 if Is_Effectively_Volatile
(Obj_Id
) then
837 -- The declaration of an effectively volatile object must
838 -- appear at the library level (SPARK RM 7.1.3(3), C.6(6)).
840 if not Is_Library_Level_Entity
(Obj_Id
) then
842 ("volatile variable & must be declared at library level",
845 -- An object of a discriminated type cannot be effectively
846 -- volatile except for protected objects (SPARK RM 7.1.3(5)).
848 elsif Has_Discriminants
(Obj_Typ
)
849 and then not Is_Protected_Type
(Obj_Typ
)
852 ("discriminated object & cannot be volatile", Obj_Id
);
854 -- An object of a tagged type cannot be effectively volatile
855 -- (SPARK RM C.6(5)).
857 elsif Is_Tagged_Type
(Obj_Typ
) then
858 Error_Msg_N
("tagged object & cannot be volatile", Obj_Id
);
861 -- The object is not effectively volatile
864 -- A non-effectively volatile object cannot have effectively
865 -- volatile components (SPARK RM 7.1.3(6)).
867 if not Is_Effectively_Volatile
(Obj_Id
)
868 and then Has_Volatile_Component
(Obj_Typ
)
871 ("non-volatile object & cannot have volatile components",
876 -- A variable whose Part_Of pragma specifies a single concurrent
877 -- type as encapsulator must be (SPARK RM 9.4):
878 -- * Of a type that defines full default initialization, or
879 -- * Declared with a default value, or
882 Encap_Id
:= Encapsulating_State
(Obj_Id
);
884 if Present
(Encap_Id
)
885 and then Is_Single_Concurrent_Object
(Encap_Id
)
886 and then not Has_Full_Default_Initialization
(Etype
(Obj_Id
))
887 and then not Has_Initial_Value
(Obj_Id
)
888 and then not Is_Imported
(Obj_Id
)
890 Error_Msg_N
("& requires full default initialization", Obj_Id
);
892 Error_Msg_Name_1
:= Chars
(Encap_Id
);
894 (Fix_Msg
(Encap_Id
, "\object acts as constituent of single "
895 & "protected type %"), Obj_Id
);
902 if Comes_From_Source
(Obj_Id
) and then Is_Ghost_Entity
(Obj_Id
) then
904 -- A Ghost object cannot be of a type that yields a synchronized
905 -- object (SPARK RM 6.9(19)).
907 if Yields_Synchronized_Object
(Obj_Typ
) then
908 Error_Msg_N
("ghost object & cannot be synchronized", Obj_Id
);
910 -- A Ghost object cannot be effectively volatile (SPARK RM 6.9(8) and
911 -- SPARK RM 6.9(19)).
913 elsif Is_Effectively_Volatile
(Obj_Id
) then
914 Error_Msg_N
("ghost object & cannot be volatile", Obj_Id
);
916 -- A Ghost object cannot be imported or exported (SPARK RM 6.9(8)).
917 -- One exception to this is the object that represents the dispatch
918 -- table of a Ghost tagged type, as the symbol needs to be exported.
920 elsif Is_Exported
(Obj_Id
) then
921 Error_Msg_N
("ghost object & cannot be exported", Obj_Id
);
923 elsif Is_Imported
(Obj_Id
) then
924 Error_Msg_N
("ghost object & cannot be imported", Obj_Id
);
928 -- Restore the SPARK_Mode of the enclosing context after all delayed
929 -- pragmas have been analyzed.
932 Restore_SPARK_Mode
(Mode
);
934 end Analyze_Object_Contract
;
936 -----------------------------------
937 -- Analyze_Package_Body_Contract --
938 -----------------------------------
940 procedure Analyze_Package_Body_Contract
941 (Body_Id
: Entity_Id
;
942 Freeze_Id
: Entity_Id
:= Empty
)
944 Body_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Body_Id
);
945 Items
: constant Node_Id
:= Contract
(Body_Id
);
946 Spec_Id
: constant Entity_Id
:= Spec_Entity
(Body_Id
);
947 Mode
: SPARK_Mode_Type
;
951 -- Do not analyze a contract multiple times
953 if Present
(Items
) then
954 if Analyzed
(Items
) then
957 Set_Analyzed
(Items
);
961 -- Due to the timing of contract analysis, delayed pragmas may be
962 -- subject to the wrong SPARK_Mode, usually that of the enclosing
963 -- context. To remedy this, restore the original SPARK_Mode of the
964 -- related package body.
966 Save_SPARK_Mode_And_Set
(Body_Id
, Mode
);
968 Ref_State
:= Get_Pragma
(Body_Id
, Pragma_Refined_State
);
970 -- The analysis of pragma Refined_State detects whether the spec has
971 -- abstract states available for refinement.
973 if Present
(Ref_State
) then
974 Analyze_Refined_State_In_Decl_Part
(Ref_State
, Freeze_Id
);
976 -- State refinement is required when the package declaration defines at
977 -- least one abstract state. Null states are not considered. Refinement
978 -- is not enforced when SPARK checks are turned off.
980 elsif SPARK_Mode
/= Off
981 and then Requires_State_Refinement
(Spec_Id
, Body_Id
)
983 Error_Msg_N
("package & requires state refinement", Spec_Id
);
986 -- Restore the SPARK_Mode of the enclosing context after all delayed
987 -- pragmas have been analyzed.
989 Restore_SPARK_Mode
(Mode
);
991 -- Capture all global references in a generic package body now that the
992 -- contract has been analyzed.
994 if Is_Generic_Declaration_Or_Body
(Body_Decl
) then
995 Save_Global_References_In_Contract
996 (Templ
=> Original_Node
(Body_Decl
),
999 end Analyze_Package_Body_Contract
;
1001 ------------------------------
1002 -- Analyze_Package_Contract --
1003 ------------------------------
1005 procedure Analyze_Package_Contract
(Pack_Id
: Entity_Id
) is
1006 Items
: constant Node_Id
:= Contract
(Pack_Id
);
1007 Pack_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Pack_Id
);
1008 Init
: Node_Id
:= Empty
;
1009 Init_Cond
: Node_Id
:= Empty
;
1010 Mode
: SPARK_Mode_Type
;
1015 -- Do not analyze a contract multiple times
1017 if Present
(Items
) then
1018 if Analyzed
(Items
) then
1021 Set_Analyzed
(Items
);
1025 -- Due to the timing of contract analysis, delayed pragmas may be
1026 -- subject to the wrong SPARK_Mode, usually that of the enclosing
1027 -- context. To remedy this, restore the original SPARK_Mode of the
1030 Save_SPARK_Mode_And_Set
(Pack_Id
, Mode
);
1032 if Present
(Items
) then
1034 -- Locate and store pragmas Initial_Condition and Initializes, since
1035 -- their order of analysis matters.
1037 Prag
:= Classifications
(Items
);
1038 while Present
(Prag
) loop
1039 Prag_Nam
:= Pragma_Name
(Prag
);
1041 if Prag_Nam
= Name_Initial_Condition
then
1044 elsif Prag_Nam
= Name_Initializes
then
1048 Prag
:= Next_Pragma
(Prag
);
1051 -- Analyze the initialization-related pragmas. Initializes must come
1052 -- before Initial_Condition due to item dependencies.
1054 if Present
(Init
) then
1055 Analyze_Initializes_In_Decl_Part
(Init
);
1058 if Present
(Init_Cond
) then
1059 Analyze_Initial_Condition_In_Decl_Part
(Init_Cond
);
1063 -- Check whether the lack of indicator Part_Of agrees with the placement
1064 -- of the package instantiation with respect to the state space.
1066 if Is_Generic_Instance
(Pack_Id
) then
1067 Prag
:= Get_Pragma
(Pack_Id
, Pragma_Part_Of
);
1070 Check_Missing_Part_Of
(Pack_Id
);
1074 -- Restore the SPARK_Mode of the enclosing context after all delayed
1075 -- pragmas have been analyzed.
1077 Restore_SPARK_Mode
(Mode
);
1079 -- Capture all global references in a generic package now that the
1080 -- contract has been analyzed.
1082 if Is_Generic_Declaration_Or_Body
(Pack_Decl
) then
1083 Save_Global_References_In_Contract
1084 (Templ
=> Original_Node
(Pack_Decl
),
1087 end Analyze_Package_Contract
;
1089 --------------------------------
1090 -- Analyze_Previous_Contracts --
1091 --------------------------------
1093 procedure Analyze_Previous_Contracts
(Body_Decl
: Node_Id
) is
1094 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
1098 -- A body that is in the process of being inlined appears from source,
1099 -- but carries name _parent. Such a body does not cause "freezing" of
1102 if Chars
(Body_Id
) = Name_uParent
then
1106 -- Climb the parent chain looking for an enclosing package body. Do not
1107 -- use the scope stack, as a body uses the entity of its corresponding
1110 Par
:= Parent
(Body_Decl
);
1111 while Present
(Par
) loop
1112 if Nkind
(Par
) = N_Package_Body
then
1113 Analyze_Package_Body_Contract
1114 (Body_Id
=> Defining_Entity
(Par
),
1115 Freeze_Id
=> Defining_Entity
(Body_Decl
));
1120 Par
:= Parent
(Par
);
1123 -- Analyze the contracts of all eligible construct up to the body which
1124 -- caused the "freezing".
1126 if Is_List_Member
(Body_Decl
) then
1128 (L
=> List_Containing
(Body_Decl
),
1129 Freeze_Nod
=> Body_Decl
,
1130 Freeze_Id
=> Body_Id
);
1132 end Analyze_Previous_Contracts
;
1134 --------------------------------
1135 -- Analyze_Protected_Contract --
1136 --------------------------------
1138 procedure Analyze_Protected_Contract
(Prot_Id
: Entity_Id
) is
1139 Items
: constant Node_Id
:= Contract
(Prot_Id
);
1140 Mode
: SPARK_Mode_Type
;
1143 -- Do not analyze a contract multiple times
1145 if Present
(Items
) then
1146 if Analyzed
(Items
) then
1149 Set_Analyzed
(Items
);
1153 -- Due to the timing of contract analysis, delayed pragmas may be
1154 -- subject to the wrong SPARK_Mode, usually that of the enclosing
1155 -- context. To remedy this, restore the original SPARK_Mode of the
1156 -- related protected unit.
1158 Save_SPARK_Mode_And_Set
(Prot_Id
, Mode
);
1160 -- A protected type must define full default initialization
1161 -- (SPARK RM 9.4). This check is relevant only when SPARK_Mode is on as
1162 -- it is not a standard Ada legality rule.
1165 and then not Has_Full_Default_Initialization
(Prot_Id
)
1168 ("protected type & must define full default initialization",
1172 -- Restore the SPARK_Mode of the enclosing context after all delayed
1173 -- pragmas have been analyzed.
1175 Restore_SPARK_Mode
(Mode
);
1176 end Analyze_Protected_Contract
;
1178 -------------------------------------------
1179 -- Analyze_Subprogram_Body_Stub_Contract --
1180 -------------------------------------------
1182 procedure Analyze_Subprogram_Body_Stub_Contract
(Stub_Id
: Entity_Id
) is
1183 Stub_Decl
: constant Node_Id
:= Parent
(Parent
(Stub_Id
));
1184 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of_Stub
(Stub_Decl
);
1187 -- A subprogram body stub may act as its own spec or as the completion
1188 -- of a previous declaration. Depending on the context, the contract of
1189 -- the stub may contain two sets of pragmas.
1191 -- The stub is a completion, the applicable pragmas are:
1195 if Present
(Spec_Id
) then
1196 Analyze_Entry_Or_Subprogram_Body_Contract
(Stub_Id
);
1198 -- The stub acts as its own spec, the applicable pragmas are:
1207 Analyze_Entry_Or_Subprogram_Contract
(Stub_Id
);
1209 end Analyze_Subprogram_Body_Stub_Contract
;
1211 ---------------------------
1212 -- Analyze_Task_Contract --
1213 ---------------------------
1215 procedure Analyze_Task_Contract
(Task_Id
: Entity_Id
) is
1216 Items
: constant Node_Id
:= Contract
(Task_Id
);
1217 Mode
: SPARK_Mode_Type
;
1221 -- Do not analyze a contract multiple times
1223 if Present
(Items
) then
1224 if Analyzed
(Items
) then
1227 Set_Analyzed
(Items
);
1231 -- Due to the timing of contract analysis, delayed pragmas may be
1232 -- subject to the wrong SPARK_Mode, usually that of the enclosing
1233 -- context. To remedy this, restore the original SPARK_Mode of the
1234 -- related task unit.
1236 Save_SPARK_Mode_And_Set
(Task_Id
, Mode
);
1238 -- Analyze Global first, as Depends may mention items classified in the
1239 -- global categorization.
1241 Prag
:= Get_Pragma
(Task_Id
, Pragma_Global
);
1243 if Present
(Prag
) then
1244 Analyze_Global_In_Decl_Part
(Prag
);
1247 -- Depends must be analyzed after Global in order to see the modes of
1248 -- all global items.
1250 Prag
:= Get_Pragma
(Task_Id
, Pragma_Depends
);
1252 if Present
(Prag
) then
1253 Analyze_Depends_In_Decl_Part
(Prag
);
1256 -- Restore the SPARK_Mode of the enclosing context after all delayed
1257 -- pragmas have been analyzed.
1259 Restore_SPARK_Mode
(Mode
);
1260 end Analyze_Task_Contract
;
1262 -----------------------------
1263 -- Create_Generic_Contract --
1264 -----------------------------
1266 procedure Create_Generic_Contract
(Unit
: Node_Id
) is
1267 Templ
: constant Node_Id
:= Original_Node
(Unit
);
1268 Templ_Id
: constant Entity_Id
:= Defining_Entity
(Templ
);
1270 procedure Add_Generic_Contract_Pragma
(Prag
: Node_Id
);
1271 -- Add a single contract-related source pragma Prag to the contract of
1272 -- generic template Templ_Id.
1274 ---------------------------------
1275 -- Add_Generic_Contract_Pragma --
1276 ---------------------------------
1278 procedure Add_Generic_Contract_Pragma
(Prag
: Node_Id
) is
1279 Prag_Templ
: Node_Id
;
1282 -- Mark the pragma to prevent the premature capture of global
1283 -- references when capturing global references of the context
1284 -- (see Save_References_In_Pragma).
1286 Set_Is_Generic_Contract_Pragma
(Prag
);
1288 -- Pragmas that apply to a generic subprogram declaration are not
1289 -- part of the semantic structure of the generic template:
1292 -- procedure Example (Formal : Integer);
1293 -- pragma Precondition (Formal > 0);
1295 -- Create a generic template for such pragmas and link the template
1296 -- of the pragma with the generic template.
1298 if Nkind
(Templ
) = N_Generic_Subprogram_Declaration
then
1300 (Prag
, Copy_Generic_Node
(Prag
, Empty
, Instantiating
=> False));
1301 Prag_Templ
:= Original_Node
(Prag
);
1303 Set_Is_Generic_Contract_Pragma
(Prag_Templ
);
1304 Add_Contract_Item
(Prag_Templ
, Templ_Id
);
1306 -- Otherwise link the pragma with the generic template
1309 Add_Contract_Item
(Prag
, Templ_Id
);
1311 end Add_Generic_Contract_Pragma
;
1315 Context
: constant Node_Id
:= Parent
(Unit
);
1316 Decl
: Node_Id
:= Empty
;
1318 -- Start of processing for Create_Generic_Contract
1321 -- A generic package declaration carries contract-related source pragmas
1322 -- in its visible declarations.
1324 if Nkind
(Templ
) = N_Generic_Package_Declaration
then
1325 Set_Ekind
(Templ_Id
, E_Generic_Package
);
1327 if Present
(Visible_Declarations
(Specification
(Templ
))) then
1328 Decl
:= First
(Visible_Declarations
(Specification
(Templ
)));
1331 -- A generic package body carries contract-related source pragmas in its
1334 elsif Nkind
(Templ
) = N_Package_Body
then
1335 Set_Ekind
(Templ_Id
, E_Package_Body
);
1337 if Present
(Declarations
(Templ
)) then
1338 Decl
:= First
(Declarations
(Templ
));
1341 -- Generic subprogram declaration
1343 elsif Nkind
(Templ
) = N_Generic_Subprogram_Declaration
then
1344 if Nkind
(Specification
(Templ
)) = N_Function_Specification
then
1345 Set_Ekind
(Templ_Id
, E_Generic_Function
);
1347 Set_Ekind
(Templ_Id
, E_Generic_Procedure
);
1350 -- When the generic subprogram acts as a compilation unit, inspect
1351 -- the Pragmas_After list for contract-related source pragmas.
1353 if Nkind
(Context
) = N_Compilation_Unit
then
1354 if Present
(Aux_Decls_Node
(Context
))
1355 and then Present
(Pragmas_After
(Aux_Decls_Node
(Context
)))
1357 Decl
:= First
(Pragmas_After
(Aux_Decls_Node
(Context
)));
1360 -- Otherwise inspect the successive declarations for contract-related
1364 Decl
:= Next
(Unit
);
1367 -- A generic subprogram body carries contract-related source pragmas in
1368 -- its declarations.
1370 elsif Nkind
(Templ
) = N_Subprogram_Body
then
1371 Set_Ekind
(Templ_Id
, E_Subprogram_Body
);
1373 if Present
(Declarations
(Templ
)) then
1374 Decl
:= First
(Declarations
(Templ
));
1378 -- Inspect the relevant declarations looking for contract-related source
1379 -- pragmas and add them to the contract of the generic unit.
1381 while Present
(Decl
) loop
1382 if Comes_From_Source
(Decl
) then
1383 if Nkind
(Decl
) = N_Pragma
then
1385 -- The source pragma is a contract annotation
1387 if Is_Contract_Annotation
(Decl
) then
1388 Add_Generic_Contract_Pragma
(Decl
);
1391 -- The region where a contract-related source pragma may appear
1392 -- ends with the first source non-pragma declaration or statement.
1401 end Create_Generic_Contract
;
1403 --------------------------------
1404 -- Expand_Subprogram_Contract --
1405 --------------------------------
1407 procedure Expand_Subprogram_Contract
(Body_Id
: Entity_Id
) is
1408 Body_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Body_Id
);
1409 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
1411 procedure Add_Invariant_And_Predicate_Checks
1412 (Subp_Id
: Entity_Id
;
1413 Stmts
: in out List_Id
;
1414 Result
: out Node_Id
);
1415 -- Process the result of function Subp_Id (if applicable) and all its
1416 -- formals. Add invariant and predicate checks where applicable. The
1417 -- routine appends all the checks to list Stmts. If Subp_Id denotes a
1418 -- function, Result contains the entity of parameter _Result, to be
1419 -- used in the creation of procedure _Postconditions.
1421 procedure Append_Enabled_Item
(Item
: Node_Id
; List
: in out List_Id
);
1422 -- Append a node to a list. If there is no list, create a new one. When
1423 -- the item denotes a pragma, it is added to the list only when it is
1426 procedure Build_Postconditions_Procedure
1427 (Subp_Id
: Entity_Id
;
1429 Result
: Entity_Id
);
1430 -- Create the body of procedure _Postconditions which handles various
1431 -- assertion actions on exit from subprogram Subp_Id. Stmts is the list
1432 -- of statements to be checked on exit. Parameter Result is the entity
1433 -- of parameter _Result when Subp_Id denotes a function.
1435 function Build_Pragma_Check_Equivalent
1437 Subp_Id
: Entity_Id
:= Empty
;
1438 Inher_Id
: Entity_Id
:= Empty
) return Node_Id
;
1439 -- Transform a [refined] pre- or postcondition denoted by Prag into an
1440 -- equivalent pragma Check. When the pre- or postcondition is inherited,
1441 -- the routine corrects the references of all formals of Inher_Id to
1442 -- point to the formals of Subp_Id.
1444 procedure Process_Contract_Cases
(Stmts
: in out List_Id
);
1445 -- Process pragma Contract_Cases. This routine prepends items to the
1446 -- body declarations and appends items to list Stmts.
1448 procedure Process_Postconditions
(Stmts
: in out List_Id
);
1449 -- Collect all [inherited] spec and body postconditions and accumulate
1450 -- their pragma Check equivalents in list Stmts.
1452 procedure Process_Preconditions
;
1453 -- Collect all [inherited] spec and body preconditions and prepend their
1454 -- pragma Check equivalents to the declarations of the body.
1456 ----------------------------------------
1457 -- Add_Invariant_And_Predicate_Checks --
1458 ----------------------------------------
1460 procedure Add_Invariant_And_Predicate_Checks
1461 (Subp_Id
: Entity_Id
;
1462 Stmts
: in out List_Id
;
1463 Result
: out Node_Id
)
1465 procedure Add_Invariant_Access_Checks
(Id
: Entity_Id
);
1466 -- Id denotes the return value of a function or a formal parameter.
1467 -- Add an invariant check if the type of Id is access to a type with
1468 -- invariants. The routine appends the generated code to Stmts.
1470 function Invariant_Checks_OK
(Typ
: Entity_Id
) return Boolean;
1471 -- Determine whether type Typ can benefit from invariant checks. To
1472 -- qualify, the type must have a non-null invariant procedure and
1473 -- subprogram Subp_Id must appear visible from the point of view of
1476 ---------------------------------
1477 -- Add_Invariant_Access_Checks --
1478 ---------------------------------
1480 procedure Add_Invariant_Access_Checks
(Id
: Entity_Id
) is
1481 Loc
: constant Source_Ptr
:= Sloc
(Body_Decl
);
1488 if Is_Access_Type
(Typ
) and then not Is_Access_Constant
(Typ
) then
1489 Typ
:= Designated_Type
(Typ
);
1491 if Invariant_Checks_OK
(Typ
) then
1493 Make_Explicit_Dereference
(Loc
,
1494 Prefix
=> New_Occurrence_Of
(Id
, Loc
));
1495 Set_Etype
(Ref
, Typ
);
1498 -- if <Id> /= null then
1499 -- <invariant_call (<Ref>)>
1504 Make_If_Statement
(Loc
,
1507 Left_Opnd
=> New_Occurrence_Of
(Id
, Loc
),
1508 Right_Opnd
=> Make_Null
(Loc
)),
1509 Then_Statements
=> New_List
(
1510 Make_Invariant_Call
(Ref
))),
1514 end Add_Invariant_Access_Checks
;
1516 -------------------------
1517 -- Invariant_Checks_OK --
1518 -------------------------
1520 function Invariant_Checks_OK
(Typ
: Entity_Id
) return Boolean is
1521 function Has_Null_Body
(Proc_Id
: Entity_Id
) return Boolean;
1522 -- Determine whether the body of procedure Proc_Id contains a sole
1523 -- null statement, possibly followed by an optional return.
1525 function Has_Public_Visibility_Of_Subprogram
return Boolean;
1526 -- Determine whether type Typ has public visibility of subprogram
1533 function Has_Null_Body
(Proc_Id
: Entity_Id
) return Boolean is
1534 Body_Id
: Entity_Id
;
1541 Spec
:= Parent
(Proc_Id
);
1542 Decl
:= Parent
(Spec
);
1544 -- Retrieve the entity of the invariant procedure body
1546 if Nkind
(Spec
) = N_Procedure_Specification
1547 and then Nkind
(Decl
) = N_Subprogram_Declaration
1549 Body_Id
:= Corresponding_Body
(Decl
);
1551 -- The body acts as a spec
1557 -- The body will be generated later
1559 if No
(Body_Id
) then
1563 Spec
:= Parent
(Body_Id
);
1564 Decl
:= Parent
(Spec
);
1567 (Nkind
(Spec
) = N_Procedure_Specification
1568 and then Nkind
(Decl
) = N_Subprogram_Body
);
1570 Stmt1
:= First
(Statements
(Handled_Statement_Sequence
(Decl
)));
1572 -- Look for a null statement followed by an optional return
1575 if Nkind
(Stmt1
) = N_Null_Statement
then
1576 Stmt2
:= Next
(Stmt1
);
1578 if Present
(Stmt2
) then
1579 return Nkind
(Stmt2
) = N_Simple_Return_Statement
;
1588 -----------------------------------------
1589 -- Has_Public_Visibility_Of_Subprogram --
1590 -----------------------------------------
1592 function Has_Public_Visibility_Of_Subprogram
return Boolean is
1593 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
1596 -- An Initialization procedure must be considered visible even
1597 -- though it is internally generated.
1599 if Is_Init_Proc
(Defining_Entity
(Subp_Decl
)) then
1602 elsif Ekind
(Scope
(Typ
)) /= E_Package
then
1605 -- Internally generated code is never publicly visible except
1606 -- for a subprogram that is the implementation of an expression
1607 -- function. In that case the visibility is determined by the
1610 elsif not Comes_From_Source
(Subp_Decl
)
1612 (Nkind
(Original_Node
(Subp_Decl
)) /= N_Expression_Function
1614 Comes_From_Source
(Defining_Entity
(Subp_Decl
)))
1618 -- Determine whether the subprogram is declared in the visible
1619 -- declarations of the package containing the type.
1622 return List_Containing
(Subp_Decl
) =
1623 Visible_Declarations
1624 (Specification
(Unit_Declaration_Node
(Scope
(Typ
))));
1626 end Has_Public_Visibility_Of_Subprogram
;
1628 -- Start of processing for Invariant_Checks_OK
1632 Has_Invariants
(Typ
)
1633 and then Present
(Invariant_Procedure
(Typ
))
1634 and then not Has_Null_Body
(Invariant_Procedure
(Typ
))
1635 and then Has_Public_Visibility_Of_Subprogram
;
1636 end Invariant_Checks_OK
;
1640 Loc
: constant Source_Ptr
:= Sloc
(Body_Decl
);
1641 -- Source location of subprogram body contract
1646 -- Start of processing for Add_Invariant_And_Predicate_Checks
1651 -- Process the result of a function
1653 if Ekind
(Subp_Id
) = E_Function
then
1654 Typ
:= Etype
(Subp_Id
);
1656 -- Generate _Result which is used in procedure _Postconditions to
1657 -- verify the return value.
1659 Result
:= Make_Defining_Identifier
(Loc
, Name_uResult
);
1660 Set_Etype
(Result
, Typ
);
1662 -- Add an invariant check when the return type has invariants and
1663 -- the related function is visible to the outside.
1665 if Invariant_Checks_OK
(Typ
) then
1668 Make_Invariant_Call
(New_Occurrence_Of
(Result
, Loc
)),
1672 -- Add an invariant check when the return type is an access to a
1673 -- type with invariants.
1675 Add_Invariant_Access_Checks
(Result
);
1678 -- Add invariant and predicates for all formals that qualify
1680 Formal
:= First_Formal
(Subp_Id
);
1681 while Present
(Formal
) loop
1682 Typ
:= Etype
(Formal
);
1684 if Ekind
(Formal
) /= E_In_Parameter
1685 or else Is_Access_Type
(Typ
)
1687 if Invariant_Checks_OK
(Typ
) then
1690 Make_Invariant_Call
(New_Occurrence_Of
(Formal
, Loc
)),
1694 Add_Invariant_Access_Checks
(Formal
);
1696 -- Note: we used to add predicate checks for OUT and IN OUT
1697 -- formals here, but that was misguided, since such checks are
1698 -- performed on the caller side, based on the predicate of the
1699 -- actual, rather than the predicate of the formal.
1703 Next_Formal
(Formal
);
1705 end Add_Invariant_And_Predicate_Checks
;
1707 -------------------------
1708 -- Append_Enabled_Item --
1709 -------------------------
1711 procedure Append_Enabled_Item
(Item
: Node_Id
; List
: in out List_Id
) is
1713 -- Do not chain ignored or disabled pragmas
1715 if Nkind
(Item
) = N_Pragma
1716 and then (Is_Ignored
(Item
) or else Is_Disabled
(Item
))
1720 -- Otherwise, add the item
1727 -- If the pragma is a conjunct in a composite postcondition, it
1728 -- has been processed in reverse order. In the postcondition body
1729 -- it must appear before the others.
1731 if Nkind
(Item
) = N_Pragma
1732 and then From_Aspect_Specification
(Item
)
1733 and then Split_PPC
(Item
)
1735 Prepend
(Item
, List
);
1737 Append
(Item
, List
);
1740 end Append_Enabled_Item
;
1742 ------------------------------------
1743 -- Build_Postconditions_Procedure --
1744 ------------------------------------
1746 procedure Build_Postconditions_Procedure
1747 (Subp_Id
: Entity_Id
;
1751 procedure Insert_Before_First_Source_Declaration
(Stmt
: Node_Id
);
1752 -- Insert node Stmt before the first source declaration of the
1753 -- related subprogram's body. If no such declaration exists, Stmt
1754 -- becomes the last declaration.
1756 --------------------------------------------
1757 -- Insert_Before_First_Source_Declaration --
1758 --------------------------------------------
1760 procedure Insert_Before_First_Source_Declaration
(Stmt
: Node_Id
) is
1761 Decls
: constant List_Id
:= Declarations
(Body_Decl
);
1765 -- Inspect the declarations of the related subprogram body looking
1766 -- for the first source declaration.
1768 if Present
(Decls
) then
1769 Decl
:= First
(Decls
);
1770 while Present
(Decl
) loop
1771 if Comes_From_Source
(Decl
) then
1772 Insert_Before
(Decl
, Stmt
);
1779 -- If we get there, then the subprogram body lacks any source
1780 -- declarations. The body of _Postconditions now acts as the
1781 -- last declaration.
1783 Append
(Stmt
, Decls
);
1785 -- Ensure that the body has a declaration list
1788 Set_Declarations
(Body_Decl
, New_List
(Stmt
));
1790 end Insert_Before_First_Source_Declaration
;
1794 Loc
: constant Source_Ptr
:= Sloc
(Body_Decl
);
1795 Params
: List_Id
:= No_List
;
1797 Proc_Id
: Entity_Id
;
1799 -- Start of processing for Build_Postconditions_Procedure
1802 -- Nothing to do if there are no actions to check on exit
1808 Proc_Id
:= Make_Defining_Identifier
(Loc
, Name_uPostconditions
);
1809 Set_Debug_Info_Needed
(Proc_Id
);
1810 Set_Postconditions_Proc
(Subp_Id
, Proc_Id
);
1812 -- The related subprogram is a function: create the specification of
1813 -- parameter _Result.
1815 if Present
(Result
) then
1816 Params
:= New_List
(
1817 Make_Parameter_Specification
(Loc
,
1818 Defining_Identifier
=> Result
,
1820 New_Occurrence_Of
(Etype
(Result
), Loc
)));
1823 -- Insert _Postconditions before the first source declaration of the
1824 -- body. This ensures that the body will not cause any premature
1825 -- freezing, as it may mention types:
1827 -- procedure Proc (Obj : Array_Typ) is
1828 -- procedure _postconditions is
1831 -- end _postconditions;
1833 -- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1));
1836 -- In the example above, Obj is of type T but the incorrect placement
1837 -- of _Postconditions will cause a crash in gigi due to an out-of-
1838 -- order reference. The body of _Postconditions must be placed after
1839 -- the declaration of Temp to preserve correct visibility.
1841 -- Set an explicit End_Label to override the sloc of the implicit
1842 -- RETURN statement, and prevent it from inheriting the sloc of one
1843 -- the postconditions: this would cause confusing debug info to be
1844 -- produced, interfering with coverage-analysis tools.
1847 Make_Subprogram_Body
(Loc
,
1849 Make_Procedure_Specification
(Loc
,
1850 Defining_Unit_Name
=> Proc_Id
,
1851 Parameter_Specifications
=> Params
),
1853 Declarations
=> Empty_List
,
1854 Handled_Statement_Sequence
=>
1855 Make_Handled_Sequence_Of_Statements
(Loc
,
1856 Statements
=> Stmts
,
1857 End_Label
=> Make_Identifier
(Loc
, Chars
(Proc_Id
))));
1859 Insert_Before_First_Source_Declaration
(Proc_Bod
);
1861 end Build_Postconditions_Procedure
;
1863 -----------------------------------
1864 -- Build_Pragma_Check_Equivalent --
1865 -----------------------------------
1867 function Build_Pragma_Check_Equivalent
1869 Subp_Id
: Entity_Id
:= Empty
;
1870 Inher_Id
: Entity_Id
:= Empty
) return Node_Id
1872 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
1873 -- Detect whether node N references a formal parameter subject to
1874 -- pragma Unreferenced. If this is the case, set Comes_From_Source
1875 -- to False to suppress the generation of a reference when analyzing
1878 ------------------------
1879 -- Suppress_Reference --
1880 ------------------------
1882 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
1886 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
1887 Formal
:= Entity
(N
);
1889 -- The formal parameter is subject to pragma Unreferenced.
1890 -- Prevent the generation of a reference by resetting the
1891 -- Comes_From_Source flag.
1893 if Is_Formal
(Formal
)
1894 and then Has_Pragma_Unreferenced
(Formal
)
1896 Set_Comes_From_Source
(N
, False);
1901 end Suppress_Reference
;
1903 procedure Suppress_References
is
1904 new Traverse_Proc
(Suppress_Reference
);
1908 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
1909 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
1910 Check_Prag
: Node_Id
;
1911 Formals_Map
: Elist_Id
;
1912 Inher_Formal
: Entity_Id
;
1915 Subp_Formal
: Entity_Id
;
1917 -- Start of processing for Build_Pragma_Check_Equivalent
1920 Formals_Map
:= No_Elist
;
1922 -- When the pre- or postcondition is inherited, map the formals of
1923 -- the inherited subprogram to those of the current subprogram.
1925 if Present
(Inher_Id
) then
1926 pragma Assert
(Present
(Subp_Id
));
1928 Formals_Map
:= New_Elmt_List
;
1930 -- Create a relation <inherited formal> => <subprogram formal>
1932 Inher_Formal
:= First_Formal
(Inher_Id
);
1933 Subp_Formal
:= First_Formal
(Subp_Id
);
1934 while Present
(Inher_Formal
) and then Present
(Subp_Formal
) loop
1935 Append_Elmt
(Inher_Formal
, Formals_Map
);
1936 Append_Elmt
(Subp_Formal
, Formals_Map
);
1938 Next_Formal
(Inher_Formal
);
1939 Next_Formal
(Subp_Formal
);
1943 -- Copy the original pragma while performing substitutions (if
1950 New_Scope
=> Current_Scope
);
1952 -- Mark the pragma as being internally generated and reset the
1955 Set_Analyzed
(Check_Prag
, False);
1956 Set_Comes_From_Source
(Check_Prag
, False);
1958 -- The tree of the original pragma may contain references to the
1959 -- formal parameters of the related subprogram. At the same time
1960 -- the corresponding body may mark the formals as unreferenced:
1962 -- procedure Proc (Formal : ...)
1963 -- with Pre => Formal ...;
1965 -- procedure Proc (Formal : ...) is
1966 -- pragma Unreferenced (Formal);
1969 -- This creates problems because all pragma Check equivalents are
1970 -- analyzed at the end of the body declarations. Since all source
1971 -- references have already been accounted for, reset any references
1972 -- to such formals in the generated pragma Check equivalent.
1974 Suppress_References
(Check_Prag
);
1976 if Present
(Corresponding_Aspect
(Prag
)) then
1977 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
1982 -- Convert the copy into pragma Check by correcting the name and
1983 -- adding a check_kind argument.
1985 Set_Pragma_Identifier
1986 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
1988 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
1989 Make_Pragma_Argument_Association
(Loc
,
1990 Expression
=> Make_Identifier
(Loc
, Nam
)));
1992 -- Update the error message when the pragma is inherited
1994 if Present
(Inher_Id
) then
1995 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
1997 if Chars
(Msg_Arg
) = Name_Message
then
1998 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
2000 -- Insert "inherited" to improve the error message
2002 if Name_Buffer
(1 .. 8) = "failed p" then
2003 Insert_Str_In_Name_Buffer
("inherited ", 8);
2004 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
2010 end Build_Pragma_Check_Equivalent
;
2012 ----------------------------
2013 -- Process_Contract_Cases --
2014 ----------------------------
2016 procedure Process_Contract_Cases
(Stmts
: in out List_Id
) is
2017 procedure Process_Contract_Cases_For
(Subp_Id
: Entity_Id
);
2018 -- Process pragma Contract_Cases for subprogram Subp_Id
2020 --------------------------------
2021 -- Process_Contract_Cases_For --
2022 --------------------------------
2024 procedure Process_Contract_Cases_For
(Subp_Id
: Entity_Id
) is
2025 Items
: constant Node_Id
:= Contract
(Subp_Id
);
2029 if Present
(Items
) then
2030 Prag
:= Contract_Test_Cases
(Items
);
2031 while Present
(Prag
) loop
2032 if Pragma_Name
(Prag
) = Name_Contract_Cases
then
2033 Expand_Pragma_Contract_Cases
2036 Decls
=> Declarations
(Body_Decl
),
2040 Prag
:= Next_Pragma
(Prag
);
2043 end Process_Contract_Cases_For
;
2045 -- Start of processing for Process_Contract_Cases
2048 Process_Contract_Cases_For
(Body_Id
);
2050 if Present
(Spec_Id
) then
2051 Process_Contract_Cases_For
(Spec_Id
);
2053 end Process_Contract_Cases
;
2055 ----------------------------
2056 -- Process_Postconditions --
2057 ----------------------------
2059 procedure Process_Postconditions
(Stmts
: in out List_Id
) is
2060 procedure Process_Body_Postconditions
(Post_Nam
: Name_Id
);
2061 -- Collect all [refined] postconditions of a specific kind denoted
2062 -- by Post_Nam that belong to the body, and generate pragma Check
2063 -- equivalents in list Stmts.
2065 procedure Process_Spec_Postconditions
;
2066 -- Collect all [inherited] postconditions of the spec, and generate
2067 -- pragma Check equivalents in list Stmts.
2069 ---------------------------------
2070 -- Process_Body_Postconditions --
2071 ---------------------------------
2073 procedure Process_Body_Postconditions
(Post_Nam
: Name_Id
) is
2074 Items
: constant Node_Id
:= Contract
(Body_Id
);
2075 Unit_Decl
: constant Node_Id
:= Parent
(Body_Decl
);
2080 -- Process the contract
2082 if Present
(Items
) then
2083 Prag
:= Pre_Post_Conditions
(Items
);
2084 while Present
(Prag
) loop
2085 if Pragma_Name
(Prag
) = Post_Nam
then
2087 (Item
=> Build_Pragma_Check_Equivalent
(Prag
),
2091 Prag
:= Next_Pragma
(Prag
);
2095 -- The subprogram body being processed is actually the proper body
2096 -- of a stub with a corresponding spec. The subprogram stub may
2097 -- carry a postcondition pragma, in which case it must be taken
2098 -- into account. The pragma appears after the stub.
2100 if Present
(Spec_Id
) and then Nkind
(Unit_Decl
) = N_Subunit
then
2101 Decl
:= Next
(Corresponding_Stub
(Unit_Decl
));
2102 while Present
(Decl
) loop
2104 -- Note that non-matching pragmas are skipped
2106 if Nkind
(Decl
) = N_Pragma
then
2107 if Pragma_Name
(Decl
) = Post_Nam
then
2109 (Item
=> Build_Pragma_Check_Equivalent
(Decl
),
2113 -- Skip internally generated code
2115 elsif not Comes_From_Source
(Decl
) then
2118 -- Postcondition pragmas are usually grouped together. There
2119 -- is no need to inspect the whole declarative list.
2128 end Process_Body_Postconditions
;
2130 ---------------------------------
2131 -- Process_Spec_Postconditions --
2132 ---------------------------------
2134 procedure Process_Spec_Postconditions
is
2135 Subps
: constant Subprogram_List
:=
2136 Inherited_Subprograms
(Spec_Id
);
2139 Subp_Id
: Entity_Id
;
2142 -- Process the contract
2144 Items
:= Contract
(Spec_Id
);
2146 if Present
(Items
) then
2147 Prag
:= Pre_Post_Conditions
(Items
);
2148 while Present
(Prag
) loop
2149 if Pragma_Name
(Prag
) = Name_Postcondition
then
2151 (Item
=> Build_Pragma_Check_Equivalent
(Prag
),
2155 Prag
:= Next_Pragma
(Prag
);
2159 -- Process the contracts of all inherited subprograms, looking for
2160 -- class-wide postconditions.
2162 for Index
in Subps
'Range loop
2163 Subp_Id
:= Subps
(Index
);
2164 Items
:= Contract
(Subp_Id
);
2166 if Present
(Items
) then
2167 Prag
:= Pre_Post_Conditions
(Items
);
2168 while Present
(Prag
) loop
2169 if Pragma_Name
(Prag
) = Name_Postcondition
2170 and then Class_Present
(Prag
)
2174 Build_Pragma_Check_Equivalent
2177 Inher_Id
=> Subp_Id
),
2181 Prag
:= Next_Pragma
(Prag
);
2185 end Process_Spec_Postconditions
;
2187 -- Start of processing for Process_Postconditions
2190 -- The processing of postconditions is done in reverse order (body
2191 -- first) to ensure the following arrangement:
2193 -- <refined postconditions from body>
2194 -- <postconditions from body>
2195 -- <postconditions from spec>
2196 -- <inherited postconditions>
2198 Process_Body_Postconditions
(Name_Refined_Post
);
2199 Process_Body_Postconditions
(Name_Postcondition
);
2201 if Present
(Spec_Id
) then
2202 Process_Spec_Postconditions
;
2204 end Process_Postconditions
;
2206 ---------------------------
2207 -- Process_Preconditions --
2208 ---------------------------
2210 procedure Process_Preconditions
is
2211 Class_Pre
: Node_Id
:= Empty
;
2212 -- The sole [inherited] class-wide precondition pragma that applies
2213 -- to the subprogram.
2215 Insert_Node
: Node_Id
:= Empty
;
2216 -- The insertion node after which all pragma Check equivalents are
2219 procedure Merge_Preconditions
(From
: Node_Id
; Into
: Node_Id
);
2220 -- Merge two class-wide preconditions by "or else"-ing them. The
2221 -- changes are accumulated in parameter Into. Update the error
2224 procedure Prepend_To_Decls
(Item
: Node_Id
);
2225 -- Prepend a single item to the declarations of the subprogram body
2227 procedure Prepend_To_Decls_Or_Save
(Prag
: Node_Id
);
2228 -- Save a class-wide precondition into Class_Pre, or prepend a normal
2229 -- precondition to the declarations of the body and analyze it.
2231 procedure Process_Inherited_Preconditions
;
2232 -- Collect all inherited class-wide preconditions and merge them into
2233 -- one big precondition to be evaluated as pragma Check.
2235 procedure Process_Preconditions_For
(Subp_Id
: Entity_Id
);
2236 -- Collect all preconditions of subprogram Subp_Id and prepend their
2237 -- pragma Check equivalents to the declarations of the body.
2239 -------------------------
2240 -- Merge_Preconditions --
2241 -------------------------
2243 procedure Merge_Preconditions
(From
: Node_Id
; Into
: Node_Id
) is
2244 function Expression_Arg
(Prag
: Node_Id
) return Node_Id
;
2245 -- Return the boolean expression argument of a precondition while
2246 -- updating its parentheses count for the subsequent merge.
2248 function Message_Arg
(Prag
: Node_Id
) return Node_Id
;
2249 -- Return the message argument of a precondition
2251 --------------------
2252 -- Expression_Arg --
2253 --------------------
2255 function Expression_Arg
(Prag
: Node_Id
) return Node_Id
is
2256 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
2257 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Next
(First
(Args
)));
2260 if Paren_Count
(Arg
) = 0 then
2261 Set_Paren_Count
(Arg
, 1);
2271 function Message_Arg
(Prag
: Node_Id
) return Node_Id
is
2272 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
2274 return Get_Pragma_Arg
(Last
(Args
));
2279 From_Expr
: constant Node_Id
:= Expression_Arg
(From
);
2280 From_Msg
: constant Node_Id
:= Message_Arg
(From
);
2281 Into_Expr
: constant Node_Id
:= Expression_Arg
(Into
);
2282 Into_Msg
: constant Node_Id
:= Message_Arg
(Into
);
2283 Loc
: constant Source_Ptr
:= Sloc
(Into
);
2285 -- Start of processing for Merge_Preconditions
2288 -- Merge the two preconditions by "or else"-ing them
2292 Right_Opnd
=> Relocate_Node
(Into_Expr
),
2293 Left_Opnd
=> From_Expr
));
2295 -- Merge the two error messages to produce a single message of the
2298 -- failed precondition from ...
2299 -- also failed inherited precondition from ...
2301 if not Exception_Locations_Suppressed
then
2302 Start_String
(Strval
(Into_Msg
));
2303 Store_String_Char
(ASCII
.LF
);
2304 Store_String_Chars
(" also ");
2305 Store_String_Chars
(Strval
(From_Msg
));
2307 Set_Strval
(Into_Msg
, End_String
);
2309 end Merge_Preconditions
;
2311 ----------------------
2312 -- Prepend_To_Decls --
2313 ----------------------
2315 procedure Prepend_To_Decls
(Item
: Node_Id
) is
2316 Decls
: List_Id
:= Declarations
(Body_Decl
);
2319 -- Ensure that the body has a declarative list
2323 Set_Declarations
(Body_Decl
, Decls
);
2326 Prepend_To
(Decls
, Item
);
2327 end Prepend_To_Decls
;
2329 ------------------------------
2330 -- Prepend_To_Decls_Or_Save --
2331 ------------------------------
2333 procedure Prepend_To_Decls_Or_Save
(Prag
: Node_Id
) is
2334 Check_Prag
: Node_Id
;
2337 Check_Prag
:= Build_Pragma_Check_Equivalent
(Prag
);
2339 -- Save the sole class-wide precondition (if any) for the next
2340 -- step, where it will be merged with inherited preconditions.
2342 if Class_Present
(Prag
) then
2343 pragma Assert
(No
(Class_Pre
));
2344 Class_Pre
:= Check_Prag
;
2346 -- Accumulate the corresponding Check pragmas at the top of the
2347 -- declarations. Prepending the items ensures that they will be
2348 -- evaluated in their original order.
2351 if Present
(Insert_Node
) then
2352 Insert_After
(Insert_Node
, Check_Prag
);
2354 Prepend_To_Decls
(Check_Prag
);
2357 Analyze
(Check_Prag
);
2359 end Prepend_To_Decls_Or_Save
;
2361 -------------------------------------
2362 -- Process_Inherited_Preconditions --
2363 -------------------------------------
2365 procedure Process_Inherited_Preconditions
is
2366 Subps
: constant Subprogram_List
:=
2367 Inherited_Subprograms
(Spec_Id
);
2368 Check_Prag
: Node_Id
;
2371 Subp_Id
: Entity_Id
;
2374 -- Process the contracts of all inherited subprograms, looking for
2375 -- class-wide preconditions.
2377 for Index
in Subps
'Range loop
2378 Subp_Id
:= Subps
(Index
);
2379 Items
:= Contract
(Subp_Id
);
2381 if Present
(Items
) then
2382 Prag
:= Pre_Post_Conditions
(Items
);
2383 while Present
(Prag
) loop
2384 if Pragma_Name
(Prag
) = Name_Precondition
2385 and then Class_Present
(Prag
)
2388 Build_Pragma_Check_Equivalent
2391 Inher_Id
=> Subp_Id
);
2393 -- The spec of an inherited subprogram already yielded
2394 -- a class-wide precondition. Merge the existing
2395 -- precondition with the current one using "or else".
2397 if Present
(Class_Pre
) then
2398 Merge_Preconditions
(Check_Prag
, Class_Pre
);
2400 Class_Pre
:= Check_Prag
;
2404 Prag
:= Next_Pragma
(Prag
);
2409 -- Add the merged class-wide preconditions
2411 if Present
(Class_Pre
) then
2412 Prepend_To_Decls
(Class_Pre
);
2413 Analyze
(Class_Pre
);
2415 end Process_Inherited_Preconditions
;
2417 -------------------------------
2418 -- Process_Preconditions_For --
2419 -------------------------------
2421 procedure Process_Preconditions_For
(Subp_Id
: Entity_Id
) is
2422 Items
: constant Node_Id
:= Contract
(Subp_Id
);
2425 Subp_Decl
: Node_Id
;
2428 -- Process the contract
2430 if Present
(Items
) then
2431 Prag
:= Pre_Post_Conditions
(Items
);
2432 while Present
(Prag
) loop
2433 if Pragma_Name
(Prag
) = Name_Precondition
then
2434 Prepend_To_Decls_Or_Save
(Prag
);
2437 Prag
:= Next_Pragma
(Prag
);
2441 -- The subprogram declaration being processed is actually a body
2442 -- stub. The stub may carry a precondition pragma, in which case
2443 -- it must be taken into account. The pragma appears after the
2446 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
2448 if Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
then
2450 -- Inspect the declarations following the body stub
2452 Decl
:= Next
(Subp_Decl
);
2453 while Present
(Decl
) loop
2455 -- Note that non-matching pragmas are skipped
2457 if Nkind
(Decl
) = N_Pragma
then
2458 if Pragma_Name
(Decl
) = Name_Precondition
then
2459 Prepend_To_Decls_Or_Save
(Decl
);
2462 -- Skip internally generated code
2464 elsif not Comes_From_Source
(Decl
) then
2467 -- Preconditions are usually grouped together. There is no
2468 -- need to inspect the whole declarative list.
2477 end Process_Preconditions_For
;
2481 Decls
: constant List_Id
:= Declarations
(Body_Decl
);
2484 -- Start of processing for Process_Preconditions
2487 -- Find the last internally generated declaration, starting from the
2488 -- top of the body declarations. This ensures that discriminals and
2489 -- subtypes are properly visible to the pragma Check equivalents.
2491 if Present
(Decls
) then
2492 Decl
:= First
(Decls
);
2493 while Present
(Decl
) loop
2494 exit when Comes_From_Source
(Decl
);
2495 Insert_Node
:= Decl
;
2500 -- The processing of preconditions is done in reverse order (body
2501 -- first), because each pragma Check equivalent is inserted at the
2502 -- top of the declarations. This ensures that the final order is
2503 -- consistent with following diagram:
2505 -- <inherited preconditions>
2506 -- <preconditions from spec>
2507 -- <preconditions from body>
2509 Process_Preconditions_For
(Body_Id
);
2511 if Present
(Spec_Id
) then
2512 Process_Preconditions_For
(Spec_Id
);
2513 Process_Inherited_Preconditions
;
2515 end Process_Preconditions
;
2519 Restore_Scope
: Boolean := False;
2521 Stmts
: List_Id
:= No_List
;
2522 Subp_Id
: Entity_Id
;
2524 -- Start of processing for Expand_Subprogram_Contract
2527 -- Obtain the entity of the initial declaration
2529 if Present
(Spec_Id
) then
2535 -- Do not perform expansion activity when it is not needed
2537 if not Expander_Active
then
2540 -- ASIS requires an unaltered tree
2542 elsif ASIS_Mode
then
2545 -- GNATprove does not need the executable semantics of a contract
2547 elsif GNATprove_Mode
then
2550 -- The contract of a generic subprogram or one declared in a generic
2551 -- context is not expanded, as the corresponding instance will provide
2552 -- the executable semantics of the contract.
2554 elsif Is_Generic_Subprogram
(Subp_Id
) or else Inside_A_Generic
then
2557 -- All subprograms carry a contract, but for some it is not significant
2558 -- and should not be processed. This is a small optimization.
2560 elsif not Has_Significant_Contract
(Subp_Id
) then
2563 -- The contract of an ignored Ghost subprogram does not need expansion,
2564 -- because the subprogram and all calls to it will be removed.
2566 elsif Is_Ignored_Ghost_Entity
(Subp_Id
) then
2570 -- Do not re-expand the same contract. This scenario occurs when a
2571 -- construct is rewritten into something else during its analysis
2572 -- (expression functions for instance).
2574 if Has_Expanded_Contract
(Subp_Id
) then
2577 -- Otherwise mark the subprogram
2580 Set_Has_Expanded_Contract
(Subp_Id
);
2583 -- Ensure that the formal parameters are visible when expanding all
2586 if not In_Open_Scopes
(Subp_Id
) then
2587 Restore_Scope
:= True;
2588 Push_Scope
(Subp_Id
);
2590 if Is_Generic_Subprogram
(Subp_Id
) then
2591 Install_Generic_Formals
(Subp_Id
);
2593 Install_Formals
(Subp_Id
);
2597 -- The expansion of a subprogram contract involves the creation of Check
2598 -- pragmas to verify the contract assertions of the spec and body in a
2599 -- particular order. The order is as follows:
2601 -- function Example (...) return ... is
2602 -- procedure _Postconditions (...) is
2604 -- <refined postconditions from body>
2605 -- <postconditions from body>
2606 -- <postconditions from spec>
2607 -- <inherited postconditions>
2608 -- <contract case consequences>
2609 -- <invariant check of function result>
2610 -- <invariant and predicate checks of parameters>
2611 -- end _Postconditions;
2613 -- <inherited preconditions>
2614 -- <preconditions from spec>
2615 -- <preconditions from body>
2616 -- <contract case conditions>
2618 -- <source declarations>
2620 -- <source statements>
2622 -- _Preconditions (Result);
2626 -- Routine _Postconditions holds all contract assertions that must be
2627 -- verified on exit from the related subprogram.
2629 -- Step 1: Handle all preconditions. This action must come before the
2630 -- processing of pragma Contract_Cases because the pragma prepends items
2631 -- to the body declarations.
2633 Process_Preconditions
;
2635 -- Step 2: Handle all postconditions. This action must come before the
2636 -- processing of pragma Contract_Cases because the pragma appends items
2639 Process_Postconditions
(Stmts
);
2641 -- Step 3: Handle pragma Contract_Cases. This action must come before
2642 -- the processing of invariants and predicates because those append
2643 -- items to list Stmts.
2645 Process_Contract_Cases
(Stmts
);
2647 -- Step 4: Apply invariant and predicate checks on a function result and
2648 -- all formals. The resulting checks are accumulated in list Stmts.
2650 Add_Invariant_And_Predicate_Checks
(Subp_Id
, Stmts
, Result
);
2652 -- Step 5: Construct procedure _Postconditions
2654 Build_Postconditions_Procedure
(Subp_Id
, Stmts
, Result
);
2656 if Restore_Scope
then
2659 end Expand_Subprogram_Contract
;
2661 ---------------------------------
2662 -- Inherit_Subprogram_Contract --
2663 ---------------------------------
2665 procedure Inherit_Subprogram_Contract
2667 From_Subp
: Entity_Id
)
2669 procedure Inherit_Pragma
(Prag_Id
: Pragma_Id
);
2670 -- Propagate a pragma denoted by Prag_Id from From_Subp's contract to
2673 --------------------
2674 -- Inherit_Pragma --
2675 --------------------
2677 procedure Inherit_Pragma
(Prag_Id
: Pragma_Id
) is
2678 Prag
: constant Node_Id
:= Get_Pragma
(From_Subp
, Prag_Id
);
2682 -- A pragma cannot be part of more than one First_Pragma/Next_Pragma
2683 -- chains, therefore the node must be replicated. The new pragma is
2684 -- flagged as inherited for distinction purposes.
2686 if Present
(Prag
) then
2687 New_Prag
:= New_Copy_Tree
(Prag
);
2688 Set_Is_Inherited_Pragma
(New_Prag
);
2690 Add_Contract_Item
(New_Prag
, Subp
);
2694 -- Start of processing for Inherit_Subprogram_Contract
2697 -- Inheritance is carried out only when both entities are subprograms
2700 if Is_Subprogram_Or_Generic_Subprogram
(Subp
)
2701 and then Is_Subprogram_Or_Generic_Subprogram
(From_Subp
)
2702 and then Present
(Contract
(From_Subp
))
2704 Inherit_Pragma
(Pragma_Extensions_Visible
);
2706 end Inherit_Subprogram_Contract
;
2708 -------------------------------------
2709 -- Instantiate_Subprogram_Contract --
2710 -------------------------------------
2712 procedure Instantiate_Subprogram_Contract
(Templ
: Node_Id
; L
: List_Id
) is
2713 procedure Instantiate_Pragmas
(First_Prag
: Node_Id
);
2714 -- Instantiate all contract-related source pragmas found in the list,
2715 -- starting with pragma First_Prag. Each instantiated pragma is added
2718 -------------------------
2719 -- Instantiate_Pragmas --
2720 -------------------------
2722 procedure Instantiate_Pragmas
(First_Prag
: Node_Id
) is
2723 Inst_Prag
: Node_Id
;
2728 while Present
(Prag
) loop
2729 if Is_Generic_Contract_Pragma
(Prag
) then
2731 Copy_Generic_Node
(Prag
, Empty
, Instantiating
=> True);
2733 Set_Analyzed
(Inst_Prag
, False);
2734 Append_To
(L
, Inst_Prag
);
2737 Prag
:= Next_Pragma
(Prag
);
2739 end Instantiate_Pragmas
;
2743 Items
: constant Node_Id
:= Contract
(Defining_Entity
(Templ
));
2745 -- Start of processing for Instantiate_Subprogram_Contract
2748 if Present
(Items
) then
2749 Instantiate_Pragmas
(Pre_Post_Conditions
(Items
));
2750 Instantiate_Pragmas
(Contract_Test_Cases
(Items
));
2751 Instantiate_Pragmas
(Classifications
(Items
));
2753 end Instantiate_Subprogram_Contract
;
2755 ----------------------------------------
2756 -- Save_Global_References_In_Contract --
2757 ----------------------------------------
2759 procedure Save_Global_References_In_Contract
2763 procedure Save_Global_References_In_List
(First_Prag
: Node_Id
);
2764 -- Save all global references in contract-related source pragmas found
2765 -- in the list, starting with pragma First_Prag.
2767 ------------------------------------
2768 -- Save_Global_References_In_List --
2769 ------------------------------------
2771 procedure Save_Global_References_In_List
(First_Prag
: Node_Id
) is
2776 while Present
(Prag
) loop
2777 if Is_Generic_Contract_Pragma
(Prag
) then
2778 Save_Global_References
(Prag
);
2781 Prag
:= Next_Pragma
(Prag
);
2783 end Save_Global_References_In_List
;
2787 Items
: constant Node_Id
:= Contract
(Defining_Entity
(Templ
));
2789 -- Start of processing for Save_Global_References_In_Contract
2792 -- The entity of the analyzed generic copy must be on the scope stack
2793 -- to ensure proper detection of global references.
2795 Push_Scope
(Gen_Id
);
2797 if Permits_Aspect_Specifications
(Templ
)
2798 and then Has_Aspects
(Templ
)
2800 Save_Global_References_In_Aspects
(Templ
);
2803 if Present
(Items
) then
2804 Save_Global_References_In_List
(Pre_Post_Conditions
(Items
));
2805 Save_Global_References_In_List
(Contract_Test_Cases
(Items
));
2806 Save_Global_References_In_List
(Classifications
(Items
));
2810 end Save_Global_References_In_Contract
;