@@ -355,13 +355,37 @@ package body Tree_Walk is
355
355
Old_Type : Entity_Id;
356
356
New_Type : Entity_Id) return Irep;
357
357
358
+ type Construct is (Declaration, Statement);
359
+
360
+ procedure Warn_Unhandled_Construct (C : Construct; Mess : String);
361
+
362
+ procedure Process_Declaration (N : Node_Id; Block : Irep);
363
+ -- with Pre => Nkind (N) in N_Declaration or else
364
+ -- Nkind (N) in N_Number_Declaration or else
365
+ -- Nkind (N) in N_Later_Decl_Item or else
366
+ -- Nkind (N) in N_Pragma or else
367
+ -- Nkind (N) in N_Exception_Declaration or else
368
+ -- Nkind (N) in N_Freeze_Entity;
369
+ -- Precondition commented out because full extend of declrations not yet known
370
+ -- Handles both a basic declaration and a declarative item.
371
+
372
+ procedure Process_Declarations (L : List_Id; Block : Irep);
373
+ -- Processes the declarations and is used for both a package specification
374
+ -- where only basic declarations are allowed (no subprogram bodies etc.)
375
+ -- and declarative parts where such declaratios are allowed.
376
+ -- The Gnat front end will check that only allowed declarations are used
377
+ -- where only basic declarations permitted.
378
+ -- Process_Declarations is a procedure rather than a function like its
379
+ -- sister Process_Statements because the Irep (an I_Code_Block) has to be
380
+ -- extended in package_specifications when it has private declarations.
381
+
358
382
procedure Process_Statement (N : Node_Id; Block : Irep)
359
383
with Pre => Kind (Block) = I_Code_Block;
360
- -- Process statement or declaration
384
+ -- Process statement
361
385
362
386
function Process_Statements (L : List_Id) return Irep
363
387
with Post => Kind (Process_Statements'Result) = I_Code_Block;
364
- -- Process list of statements or declarations
388
+ -- Process list of statements
365
389
366
390
procedure Register_Subprogram_Specification (N : Node_Id)
367
391
with Pre => Nkind (N) in N_Subprogram_Specification;
@@ -4911,81 +4935,247 @@ package body Tree_Walk is
4911
4935
end ;
4912
4936
end Maybe_Make_Typecast ;
4913
4937
4938
+ -- ------------------------------
4939
+ -- Warn_Unhandled_Construct --
4940
+ -- ------------------------------
4941
+
4942
+ procedure Warn_Unhandled_Construct (C : Construct; Mess : String) is
4943
+ S : constant String :=
4944
+ (case C is
4945
+ when Declaration => " declarations " ,
4946
+ when Statement => " statements " ) & " unhandled" ;
4947
+ begin
4948
+ Put_Line (Standard_Error, " Warning: " & Mess & S);
4949
+ end Warn_Unhandled_Construct ;
4950
+
4951
+ -- ------------------------
4952
+ -- Process_Declaration --
4953
+ -- ------------------------
4954
+
4955
+ procedure Process_Declaration (N : Node_Id; Block : Irep) is
4956
+ begin
4957
+ -- Deal with the declaration
4958
+
4959
+ case Nkind (N) is
4960
+
4961
+ -- basic_declarations --
4962
+
4963
+ when N_Full_Type_Declaration =>
4964
+ Do_Full_Type_Declaration (N);
4965
+
4966
+ when N_Subtype_Declaration =>
4967
+ Do_Subtype_Declaration (N);
4968
+
4969
+ when N_Object_Declaration =>
4970
+ Do_Object_Declaration (N, Block);
4971
+
4972
+ when N_Number_Declaration =>
4973
+ Warn_Unhandled_Construct (Declaration, " Number" );
4974
+
4975
+ when N_Subprogram_Declaration =>
4976
+ Do_Subprogram_Declaration (N);
4977
+
4978
+ when N_Abstract_Subprogram_Declaration =>
4979
+ Warn_Unhandled_Construct
4980
+ (Declaration, " Abstract subprogram" );
4981
+
4982
+ when N_Package_Declaration =>
4983
+ Warn_Unhandled_Construct (Declaration, " Package" );
4984
+
4985
+ when N_Renaming_Declaration =>
4986
+ Warn_Unhandled_Construct (Declaration, " Renaming" );
4987
+
4988
+ when N_Exception_Declaration =>
4989
+ Warn_Unhandled_Construct (Declaration, " Exception" );
4990
+
4991
+ when N_Generic_Declaration =>
4992
+ Warn_Unhandled_Construct (Declaration, " Generic" );
4993
+
4994
+ when N_Generic_Instantiation =>
4995
+ Warn_Unhandled_Construct (Declaration, " Generic instantiation" );
4996
+
4997
+ -- basic_declarative_items --
4998
+
4999
+ when N_Representation_Clause =>
5000
+ Warn_Unhandled_Construct (Declaration, " Representation clause" );
5001
+
5002
+ when N_Use_Package_Clause =>
5003
+ Warn_Unhandled_Construct (Declaration, " Use package clause" );
5004
+
5005
+ when N_Use_Type_Clause =>
5006
+ Warn_Unhandled_Construct (Declaration, " Use type clause" );
5007
+
5008
+ -- remaining declarative items --
5009
+
5010
+ -- proper_body --
5011
+
5012
+ when N_Subprogram_Body =>
5013
+ Do_Subprogram_Body (N);
5014
+
5015
+ when N_Package_Body =>
5016
+ Warn_Unhandled_Construct (Declaration, " Package body" );
5017
+
5018
+ when N_Task_Body =>
5019
+ Warn_Unhandled_Construct (Declaration, " Task body" );
5020
+
5021
+ when N_Protected_Body =>
5022
+ Warn_Unhandled_Construct (Declaration, " Protected body" );
5023
+
5024
+ -- body_stub --
5025
+
5026
+ when N_Subprogram_Body_Stub =>
5027
+ Warn_Unhandled_Construct (Declaration, " Subprogram body stub" );
5028
+
5029
+ when N_Package_Body_Stub =>
5030
+ Warn_Unhandled_Construct (Declaration, " Package body stub" );
5031
+
5032
+ when N_Task_Body_Stub =>
5033
+ Warn_Unhandled_Construct (Declaration, " Task body stub" );
5034
+
5035
+ when N_Protected_Body_Stub =>
5036
+ Warn_Unhandled_Construct (Declaration, " Protected body stub" );
5037
+
5038
+ -- Pragmas may appear in declarations --
5039
+
5040
+ when N_Pragma =>
5041
+ Warn_Unhandled_Construct (Declaration, " Pragmas in" );
5042
+
5043
+ -- Every code lable is implicitly declared in --
5044
+ -- the closest surrounding block --
5045
+
5046
+ when N_Implicit_Label_Declaration =>
5047
+ -- Ignore for now, as I guess an implicit label can't be
5048
+ -- referenced.
5049
+ -- Yes it can: this is the declaration of the name it appears
5050
+ -- the declaritve section but is used on a statement.
5051
+ null ;
5052
+
5053
+ -- Not sure the nex two should be here --
5054
+ when N_Itype_Reference =>
5055
+ Do_Itype_Reference (N);
5056
+
5057
+ when N_Freeze_Entity =>
5058
+ -- Ignore, nothing to generate
5059
+ null ;
5060
+
5061
+ when others =>
5062
+ Report_Unhandled_Node_Empty (N, " Process_Declaration" ,
5063
+ " Unknown declaration kind" );
5064
+
5065
+ end case ;
5066
+
5067
+ end Process_Declaration ;
5068
+
5069
+ -- ------------------------
5070
+ -- Process_Declarations --
5071
+ -- ------------------------
5072
+
5073
+ procedure Process_Declarations (L : List_Id; Block : Irep) is
5074
+ Decl : Node_Id := First (L);
5075
+ begin
5076
+ while Present (Decl) loop
5077
+ Process_Declaration (Decl, Block);
5078
+ Next (Decl);
5079
+ end loop ;
5080
+
5081
+ end Process_Declarations ;
5082
+
4914
5083
-- -----------------------
4915
5084
-- Process_Statement --
4916
5085
-- -----------------------
4917
5086
4918
5087
procedure Process_Statement (N : Node_Id; Block : Irep) is
4919
- procedure Warn_Unhandled_Statement (M : String);
4920
- procedure Warn_Unhandled_Statement (M : String) is
4921
- begin
4922
- Put_Line (Standard_Error, " Warning: " & M & " statements unhandled" );
4923
- end Warn_Unhandled_Statement ;
4924
5088
begin
4925
5089
-- Deal with the statement
4926
5090
case Nkind (N) is
5091
+ -- Simple statements --
5092
+ when N_Null_Statement =>
5093
+ null ;
5094
+
4927
5095
when N_Assignment_Statement =>
4928
5096
Append_Op (Block, Do_Assignment_Statement (N));
4929
5097
5098
+ when N_Exit_Statement =>
5099
+ Append_Op (Block, Do_Exit_Statement (N));
5100
+
5101
+ when N_Goto_Statement =>
5102
+ Warn_Unhandled_Construct (Statement, " goto" );
5103
+
4930
5104
when N_Procedure_Call_Statement =>
4931
5105
Append_Op (Block, Do_Procedure_Call_Statement (N));
4932
5106
4933
5107
when N_Simple_Return_Statement =>
4934
5108
Append_Op (Block, Do_Simple_Return_Statement (N));
4935
5109
4936
- when N_Object_Declaration =>
4937
- Do_Object_Declaration (N, Block );
5110
+ when N_Entry_Call_Statement =>
5111
+ Warn_Unhandled_Construct (Statement, " entry_call " );
4938
5112
4939
- when N_Handled_Sequence_Of_Statements =>
4940
- Append_Op (Block, Do_Handled_Sequence_Of_Statements (N));
5113
+ when N_Requeue_Statement =>
5114
+ Warn_Unhandled_Construct (Statement, " requeue" );
5115
+
5116
+ when N_Delay_Statement =>
5117
+ Warn_Unhandled_Construct (Statement, " delay" );
5118
+
5119
+ when N_Abort_Statement =>
5120
+ Warn_Unhandled_Construct (Statement, " abort" );
5121
+
5122
+ when N_Raise_Statement =>
5123
+ Warn_Unhandled_Construct (Statement, " raise" );
5124
+
5125
+ when N_Code_Statement =>
5126
+ Warn_Unhandled_Construct (Statement, " code" );
5127
+
5128
+ -- Compound statements
4941
5129
4942
5130
when N_If_Statement =>
4943
5131
Append_Op (Block, Do_If_Statement (N));
4944
5132
4945
- when N_Implicit_Label_Declaration =>
4946
- -- Ignore for now, as I guess an implicit label can't be
4947
- -- referenced.
4948
- null ;
5133
+ when N_Case_Statement =>
5134
+ Warn_Unhandled_Construct (Statement, " case" );
4949
5135
4950
5136
when N_Loop_Statement =>
4951
5137
Append_Op (Block, Do_Loop_Statement (N));
4952
5138
4953
- when N_Full_Type_Declaration =>
4954
- Do_Full_Type_Declaration (N );
5139
+ when N_Block_Statement =>
5140
+ Warn_Unhandled_Construct (Statement, " block " );
4955
5141
4956
- when N_Subtype_Declaration =>
4957
- Do_Subtype_Declaration (N);
5142
+ when N_Handled_Sequence_Of_Statements => -- this seems incorrct
5143
+ -- It should be block_statement
5144
+ Append_Op (Block, Do_Handled_Sequence_Of_Statements (N));
4958
5145
4959
- when N_Freeze_Entity =>
4960
- -- Ignore, nothing to generate
4961
- null ;
5146
+ when N_Extended_Return_Statement =>
5147
+ Warn_Unhandled_Construct (Statement, " extended_return" );
4962
5148
4963
- when N_Itype_Reference =>
4964
- Do_Itype_Reference (N );
5149
+ when N_Accept_Statement =>
5150
+ Warn_Unhandled_Construct (Statement, " accept " );
4965
5151
4966
- when N_Subprogram_Declaration =>
4967
- Do_Subprogram_Declaration (N);
5152
+ -- Select statements --
4968
5153
4969
- when N_Subprogram_Body =>
4970
- Do_Subprogram_Body (N );
5154
+ when N_Selective_Accept =>
5155
+ Warn_Unhandled_Construct (Statement, " selective_accept " );
4971
5156
4972
- when N_Null_Statement =>
4973
- null ;
5157
+ when N_Timed_Entry_Call =>
5158
+ Warn_Unhandled_Construct (Statement, " timed_entry_call " ) ;
4974
5159
4975
- when N_Exit_Statement =>
4976
- Append_Op (Block, Do_Exit_Statement (N));
5160
+ when N_Conditional_Entry_Call =>
5161
+ Warn_Unhandled_Construct (Statement, " conditional_entry_call" );
5162
+
5163
+ when N_Asynchronous_Select =>
5164
+ Warn_Unhandled_Construct (Statement, " asychronous select" );
5165
+
5166
+ -- Pragmas may placed in sequences of statements --
4977
5167
4978
5168
when N_Pragma =>
4979
5169
Do_Pragma (N, Block);
4980
5170
4981
- when N_Raise_Statement =>
4982
- Warn_Unhandled_Statement (" Raise" );
5171
+ -- Not sure the nex two should be here -
5172
+ -- should they be in declarations? --
5173
+ -- when N_Itype_Reference =>
5174
+ -- Do_Itype_Reference (N);
4983
5175
4984
- when N_Number_Declaration =>
4985
- Warn_Unhandled_Statement (" Number declaration" );
4986
-
4987
- when N_Case_Statement =>
4988
- Warn_Unhandled_Statement (" Case" );
5176
+ -- when N_Freeze_Entity =>
5177
+ -- -- Ignore, nothing to generate
5178
+ -- null;
4989
5179
4990
5180
when others =>
4991
5181
Report_Unhandled_Node_Empty (N, " Process_Statement" ,
0 commit comments