aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/exp_code.adb
blob: 6c6cd882d57af40624c4c8e9fb26b0f87424a291 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ C O D E                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1996-2024, 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 3,  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 COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;          use Atree;
with Einfo;          use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils;    use Einfo.Utils;
with Errout;         use Errout;
with Lib;            use Lib;
with Namet;          use Namet;
with Nlists;         use Nlists;
with Nmake;          use Nmake;
with Opt;            use Opt;
with Rtsfind;        use Rtsfind;
with Sem_Aux;        use Sem_Aux;
with Sem_Eval;       use Sem_Eval;
with Sem_Util;       use Sem_Util;
with Sem_Warn;       use Sem_Warn;
with Sinfo;          use Sinfo;
with Sinfo.Nodes;    use Sinfo.Nodes;
with Sinfo.Utils;    use Sinfo.Utils;
with Stringt;        use Stringt;
with Tbuild;         use Tbuild;

package body Exp_Code is

   -----------------------
   -- Local_Subprograms --
   -----------------------

   function Asm_Constraint (Operand_Var : Node_Id) return Node_Id;
   --  Common processing for Asm_Input_Constraint and Asm_Output_Constraint.
   --  Obtains the constraint argument from the global operand variable
   --  Operand_Var, which must be non-Empty.

   function Asm_Operand (Operand_Var : Node_Id) return Node_Id;
   --  Common processing for Asm_Input_Value and Asm_Output_Variable. Obtains
   --  the value/variable argument from Operand_Var, the global operand
   --  variable. Returns Empty if no operand available.

   function Get_String_Node (S : Node_Id) return Node_Id;
   --  Given S, a static expression node of type String, returns the
   --  string literal node. This is needed to deal with the use of constants
   --  for these expressions, which is perfectly permissible.

   procedure Next_Asm_Operand (Operand_Var : in out Node_Id);
   --  Common processing for Next_Asm_Input and Next_Asm_Output, updates
   --  the value of the global operand variable Operand_Var appropriately.

   procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id);
   --  Common processing for Setup_Asm_Inputs and Setup_Asm_Outputs. Arg
   --  is the actual parameter from the call, and Operand_Var is the global
   --  operand variable to be initialized to the first operand.

   ----------------------
   -- Global Variables --
   ----------------------

   Current_Input_Operand : Node_Id := Empty;
   --  Points to current Asm_Input_Operand attribute reference. Initialized
   --  by Setup_Asm_Inputs, updated by Next_Asm_Input, and referenced by
   --  Asm_Input_Constraint and Asm_Input_Value.

   Current_Output_Operand : Node_Id := Empty;
   --  Points to current Asm_Output_Operand attribute reference. Initialized
   --  by Setup_Asm_Outputs, updated by Next_Asm_Output, and referenced by
   --  Asm_Output_Constraint and Asm_Output_Variable.

   --------------------
   -- Asm_Constraint --
   --------------------

   function Asm_Constraint (Operand_Var : Node_Id) return Node_Id is
   begin
      pragma Assert (Present (Operand_Var));
      return Get_String_Node (First (Expressions (Operand_Var)));
   end Asm_Constraint;

   --------------------------
   -- Asm_Input_Constraint --
   --------------------------

   --  Note: error checking on Asm_Input attribute done in Sem_Attr

   function Asm_Input_Constraint return Node_Id is
   begin
      return Get_String_Node (Asm_Constraint (Current_Input_Operand));
   end Asm_Input_Constraint;

   ---------------------
   -- Asm_Input_Value --
   ---------------------

   --  Note: error checking on Asm_Input attribute done in Sem_Attr

   function Asm_Input_Value return Node_Id is
   begin
      return Asm_Operand (Current_Input_Operand);
   end Asm_Input_Value;

   -----------------
   -- Asm_Operand --
   -----------------

   function Asm_Operand (Operand_Var : Node_Id) return Node_Id is
   begin
      if No (Operand_Var) then
         return Empty;
      elsif Error_Posted (Operand_Var) then
         return Error;
      else
         return Next (First (Expressions (Operand_Var)));
      end if;
   end Asm_Operand;

   ---------------------------
   -- Asm_Output_Constraint --
   ---------------------------

   --  Note: error checking on Asm_Output attribute done in Sem_Attr

   function Asm_Output_Constraint return Node_Id is
   begin
      return Asm_Constraint (Current_Output_Operand);
   end Asm_Output_Constraint;

   -------------------------
   -- Asm_Output_Variable --
   -------------------------

   --  Note: error checking on Asm_Output attribute done in Sem_Attr

   function Asm_Output_Variable return Node_Id is
   begin
      return Asm_Operand (Current_Output_Operand);
   end Asm_Output_Variable;

   ------------------
   -- Asm_Template --
   ------------------

   function Asm_Template (N : Node_Id) return Node_Id is
      Call : constant Node_Id := Expression (Expression (N));
      Temp : constant Node_Id := First_Actual (Call);

   begin
      --  Require static expression for template. We also allow a string
      --  literal (this is useful for Ada 83 mode where string expressions
      --  are never static).

      if Is_OK_Static_Expression (Temp)
        or else (Ada_Version = Ada_83
                  and then Nkind (Temp) = N_String_Literal)
      then
         return Get_String_Node (Temp);

      else
         Flag_Non_Static_Expr ("asm template argument is not static!", Temp);
         return Empty;
      end if;
   end Asm_Template;

   ----------------------
   -- Clobber_Get_Next --
   ----------------------

   Clobber_Node : Node_Id;
   --  String literal node for clobber string. Initialized by Clobber_Setup,
   --  and not modified by Clobber_Get_Next. Empty if clobber string was in
   --  error (resulting in no clobber arguments being returned).

   Clobber_Ptr : Pos;
   --  Pointer to current character of string. Initialized to 1 by the call
   --  to Clobber_Setup, and then updated by Clobber_Get_Next.

   function Clobber_Get_Next return Address is
      Str : constant String_Id := Strval (Clobber_Node);
      Len : constant Nat       := String_Length (Str);
      C   : Character;

   begin
      if No (Clobber_Node) then
         return Null_Address;
      end if;

      --  Skip spaces and commas before next register name

      loop
         --  Return null string if no more names

         if Clobber_Ptr > Len then
            return Null_Address;
         end if;

         C := Get_Character (Get_String_Char (Str, Clobber_Ptr));
         exit when C /= ',' and then C /= ' ';
         Clobber_Ptr := Clobber_Ptr + 1;
      end loop;

      --  Acquire next register name

      Name_Len := 0;
      loop
         Add_Char_To_Name_Buffer (C);
         Clobber_Ptr := Clobber_Ptr + 1;
         exit when Clobber_Ptr > Len;
         C := Get_Character (Get_String_Char (Str, Clobber_Ptr));
         exit when C = ',' or else C = ' ';
      end loop;

      Name_Buffer (Name_Len + 1) := ASCII.NUL;
      return Name_Buffer'Address;
   end Clobber_Get_Next;

   -------------------
   -- Clobber_Setup --
   -------------------

   procedure Clobber_Setup (N : Node_Id) is
      Call : constant Node_Id := Expression (Expression (N));
      Clob : constant Node_Id := Next_Actual (
                                   Next_Actual (
                                     Next_Actual (
                                       First_Actual (Call))));
   begin
      if not Is_OK_Static_Expression (Clob) then
         Flag_Non_Static_Expr ("asm clobber argument is not static!", Clob);
         Clobber_Node := Empty;
      else
         Clobber_Node := Get_String_Node (Clob);
         Clobber_Ptr := 1;
      end if;
   end Clobber_Setup;

   ---------------------
   -- Expand_Asm_Call --
   ---------------------

   procedure Expand_Asm_Call (N : Node_Id) is
      Loc : constant Source_Ptr := Sloc (N);

      procedure Check_IO_Operand (N : Node_Id);
      --  Check for incorrect input or output operand

      ----------------------
      -- Check_IO_Operand --
      ----------------------

      procedure Check_IO_Operand (N : Node_Id) is
         Err : Node_Id := N;

      begin
         --  The only identifier allowed is No_xxput_Operands. Since we
         --  know the type is right, it is sufficient to see if the
         --  referenced entity is in a runtime routine.

         if Is_Entity_Name (N)
           and then Is_Predefined_Unit (Get_Source_Unit (Entity (N)))
         then
            return;

         --  An attribute reference is fine, again the analysis reasonably
         --  guarantees that the attribute must be subtype'Asm_??put.

         elsif Nkind (N) = N_Attribute_Reference then
            return;

         --  The only other allowed form is an array aggregate in which
         --  all the entries are positional and are attribute references.

         elsif Nkind (N) = N_Aggregate then
            if Present (Component_Associations (N)) then
               Err := First (Component_Associations (N));

            elsif Present (Expressions (N)) then
               Err := First (Expressions (N));
               while Present (Err) loop
                  exit when Nkind (Err) /= N_Attribute_Reference;
                  Next (Err);
               end loop;

               if No (Err) then
                  return;
               end if;
            end if;
         end if;

         --  If we fall through, Err is pointing to the bad node

         Error_Msg_N ("Asm operand has wrong form", Err);
      end Check_IO_Operand;

   --  Start of processing for Expand_Asm_Call

   begin
      --  Check that the input and output operands have the right
      --  form, as required by the documentation of the Asm feature:

      --  OUTPUT_OPERAND_LIST ::=
      --    No_Output_Operands
      --  | OUTPUT_OPERAND_ATTRIBUTE
      --  | (OUTPUT_OPERAND_ATTRIBUTE @{,OUTPUT_OPERAND_ATTRIBUTE@})

      --  OUTPUT_OPERAND_ATTRIBUTE ::=
      --    SUBTYPE_MARK'Asm_Output (static_string_EXPRESSION, NAME)

      --  INPUT_OPERAND_LIST ::=
      --    No_Input_Operands
      --  | INPUT_OPERAND_ATTRIBUTE
      --  | (INPUT_OPERAND_ATTRIBUTE @{,INPUT_OPERAND_ATTRIBUTE@})

      --  INPUT_OPERAND_ATTRIBUTE ::=
      --    SUBTYPE_MARK'Asm_Input (static_string_EXPRESSION, EXPRESSION)

      declare
         Arg_Output : constant Node_Id := Next_Actual (First_Actual (N));
         Arg_Input  : constant Node_Id := Next_Actual (Arg_Output);
      begin
         Check_IO_Operand (Arg_Output);
         Check_IO_Operand (Arg_Input);
      end;

      --  If we have the function call case, we are inside a code statement,
      --  and the tree is already in the necessary form for gigi.

      if Nkind (N) = N_Function_Call then
         null;

      --  For the procedure case, we convert the call into a code statement

      else
         pragma Assert (Nkind (N) = N_Procedure_Call_Statement);

         --  Note: strictly we should change the procedure call to a function
         --  call in the qualified expression, but since we are not going to
         --  reanalyze (see below), and the interface subprograms in this
         --  package don't care, we can leave it as a procedure call.

         Rewrite (N,
           Make_Code_Statement (Loc,
             Expression =>
               Make_Qualified_Expression (Loc,
                 Subtype_Mark => New_Occurrence_Of (RTE (RE_Asm_Insn), Loc),
                 Expression => Relocate_Node (N))));

         --  There is no need to reanalyze this node, it is completely analyzed
         --  already, at least sufficiently for the purposes of the abstract
         --  procedural interface defined in this package. Furthermore if we
         --  let it go through the normal analysis, that would include some
         --  inappropriate checks that apply only to explicit code statements
         --  in the source, and not to calls to intrinsics.

         Set_Analyzed (N);
         Check_Code_Statement (N);
      end if;
   end Expand_Asm_Call;

   ---------------------
   -- Get_String_Node --
   ---------------------

   function Get_String_Node (S : Node_Id) return Node_Id is
   begin
      if Nkind (S) = N_String_Literal then
         return S;
      else
         pragma Assert (Ekind (Entity (S)) = E_Constant);
         return Get_String_Node (Constant_Value (Entity (S)));
      end if;
   end Get_String_Node;

   ---------------------
   -- Is_Asm_Volatile --
   ---------------------

   function Is_Asm_Volatile (N : Node_Id) return Boolean is
      Call : constant Node_Id := Expression (Expression (N));
      Vol  : constant Node_Id :=
               Next_Actual (
                 Next_Actual (
                   Next_Actual (
                     Next_Actual (
                       First_Actual (Call)))));
   begin
      if not Is_OK_Static_Expression (Vol) then
         Flag_Non_Static_Expr ("asm volatile argument is not static!", Vol);
         return False;
      else
         return Is_True (Expr_Value (Vol));
      end if;
   end Is_Asm_Volatile;

   --------------------
   -- Next_Asm_Input --
   --------------------

   procedure Next_Asm_Input is
   begin
      Next_Asm_Operand (Current_Input_Operand);
   end Next_Asm_Input;

   ----------------------
   -- Next_Asm_Operand --
   ----------------------

   procedure Next_Asm_Operand (Operand_Var : in out Node_Id) is
   begin
      pragma Assert (Present (Operand_Var));

      if Nkind (Parent (Operand_Var)) = N_Aggregate then
         Operand_Var := Next (Operand_Var);
      else
         Operand_Var := Empty;
      end if;
   end Next_Asm_Operand;

   ---------------------
   -- Next_Asm_Output --
   ---------------------

   procedure Next_Asm_Output is
   begin
      Next_Asm_Operand (Current_Output_Operand);
   end Next_Asm_Output;

   ----------------------
   -- Setup_Asm_Inputs --
   ----------------------

   procedure Setup_Asm_Inputs (N : Node_Id) is
      Call : constant Node_Id := Expression (Expression (N));
   begin
      Setup_Asm_IO_Args
        (Next_Actual (Next_Actual (First_Actual (Call))),
         Current_Input_Operand);
   end Setup_Asm_Inputs;

   -----------------------
   -- Setup_Asm_IO_Args --
   -----------------------

   procedure Setup_Asm_IO_Args (Arg : Node_Id; Operand_Var : out Node_Id) is
   begin
      --  Case of single argument

      if Nkind (Arg) = N_Attribute_Reference then
         Operand_Var := Arg;

      --  Case of list of arguments

      elsif Nkind (Arg) = N_Aggregate then
         Operand_Var := First (Expressions (Arg));

      --  Otherwise must be default (no operands) case

      else
         Operand_Var := Empty;
      end if;
   end Setup_Asm_IO_Args;

   -----------------------
   -- Setup_Asm_Outputs --
   -----------------------

   procedure Setup_Asm_Outputs (N : Node_Id) is
      Call : constant Node_Id := Expression (Expression (N));
   begin
      Setup_Asm_IO_Args
        (Next_Actual (First_Actual (Call)),
         Current_Output_Operand);
   end Setup_Asm_Outputs;

end Exp_Code;