]> Git Repo - binutils.git/blob - gdb/f-lang.c
Remove union exp_element
[binutils.git] / gdb / f-lang.c
1 /* Fortran language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 1993-2021 Free Software Foundation, Inc.
4
5    Contributed by Motorola.  Adapted from the C parser by Farooq Butt
6    ([email protected]).
7
8    This file is part of GDB.
9
10    This program is free software; you can redistribute it and/or modify
11    it under the terms of the GNU General Public License as published by
12    the Free Software Foundation; either version 3 of the License, or
13    (at your option) any later version.
14
15    This program is distributed in the hope that it will be useful,
16    but WITHOUT ANY WARRANTY; without even the implied warranty of
17    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18    GNU General Public License for more details.
19
20    You should have received a copy of the GNU General Public License
21    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
22
23 #include "defs.h"
24 #include "symtab.h"
25 #include "gdbtypes.h"
26 #include "expression.h"
27 #include "parser-defs.h"
28 #include "language.h"
29 #include "varobj.h"
30 #include "gdbcore.h"
31 #include "f-lang.h"
32 #include "valprint.h"
33 #include "value.h"
34 #include "cp-support.h"
35 #include "charset.h"
36 #include "c-lang.h"
37 #include "target-float.h"
38 #include "gdbarch.h"
39 #include "gdbcmd.h"
40 #include "f-array-walker.h"
41 #include "f-exp.h"
42
43 #include <math.h>
44
45 /* Whether GDB should repack array slices created by the user.  */
46 static bool repack_array_slices = false;
47
48 /* Implement 'show fortran repack-array-slices'.  */
49 static void
50 show_repack_array_slices (struct ui_file *file, int from_tty,
51                           struct cmd_list_element *c, const char *value)
52 {
53   fprintf_filtered (file, _("Repacking of Fortran array slices is %s.\n"),
54                     value);
55 }
56
57 /* Debugging of Fortran's array slicing.  */
58 static bool fortran_array_slicing_debug = false;
59
60 /* Implement 'show debug fortran-array-slicing'.  */
61 static void
62 show_fortran_array_slicing_debug (struct ui_file *file, int from_tty,
63                                   struct cmd_list_element *c,
64                                   const char *value)
65 {
66   fprintf_filtered (file, _("Debugging of Fortran array slicing is %s.\n"),
67                     value);
68 }
69
70 /* Local functions */
71
72 static value *fortran_prepare_argument (struct expression *exp,
73                                         expr::operation *subexp,
74                                         int arg_num, bool is_internal_call_p,
75                                         struct type *func_type, enum noside noside);
76
77 /* Return the encoding that should be used for the character type
78    TYPE.  */
79
80 const char *
81 f_language::get_encoding (struct type *type)
82 {
83   const char *encoding;
84
85   switch (TYPE_LENGTH (type))
86     {
87     case 1:
88       encoding = target_charset (type->arch ());
89       break;
90     case 4:
91       if (type_byte_order (type) == BFD_ENDIAN_BIG)
92         encoding = "UTF-32BE";
93       else
94         encoding = "UTF-32LE";
95       break;
96
97     default:
98       error (_("unrecognized character type"));
99     }
100
101   return encoding;
102 }
103
104 \f
105
106 /* A helper function for the "bound" intrinsics that checks that TYPE
107    is an array.  LBOUND_P is true for lower bound; this is used for
108    the error message, if any.  */
109
110 static void
111 fortran_require_array (struct type *type, bool lbound_p)
112 {
113   type = check_typedef (type);
114   if (type->code () != TYPE_CODE_ARRAY)
115     {
116       if (lbound_p)
117         error (_("LBOUND can only be applied to arrays"));
118       else
119         error (_("UBOUND can only be applied to arrays"));
120     }
121 }
122
123 /* Create an array containing the lower bounds (when LBOUND_P is true) or
124    the upper bounds (when LBOUND_P is false) of ARRAY (which must be of
125    array type).  GDBARCH is the current architecture.  */
126
127 static struct value *
128 fortran_bounds_all_dims (bool lbound_p,
129                          struct gdbarch *gdbarch,
130                          struct value *array)
131 {
132   type *array_type = check_typedef (value_type (array));
133   int ndimensions = calc_f77_array_dims (array_type);
134
135   /* Allocate a result value of the correct type.  */
136   struct type *range
137     = create_static_range_type (nullptr,
138                                 builtin_type (gdbarch)->builtin_int,
139                                 1, ndimensions);
140   struct type *elm_type = builtin_type (gdbarch)->builtin_long_long;
141   struct type *result_type = create_array_type (nullptr, elm_type, range);
142   struct value *result = allocate_value (result_type);
143
144   /* Walk the array dimensions backwards due to the way the array will be
145      laid out in memory, the first dimension will be the most inner.  */
146   LONGEST elm_len = TYPE_LENGTH (elm_type);
147   for (LONGEST dst_offset = elm_len * (ndimensions - 1);
148        dst_offset >= 0;
149        dst_offset -= elm_len)
150     {
151       LONGEST b;
152
153       /* Grab the required bound.  */
154       if (lbound_p)
155         b = f77_get_lowerbound (array_type);
156       else
157         b = f77_get_upperbound (array_type);
158
159       /* And copy the value into the result value.  */
160       struct value *v = value_from_longest (elm_type, b);
161       gdb_assert (dst_offset + TYPE_LENGTH (value_type (v))
162                   <= TYPE_LENGTH (value_type (result)));
163       gdb_assert (TYPE_LENGTH (value_type (v)) == elm_len);
164       value_contents_copy (result, dst_offset, v, 0, elm_len);
165
166       /* Peel another dimension of the array.  */
167       array_type = TYPE_TARGET_TYPE (array_type);
168     }
169
170   return result;
171 }
172
173 /* Return the lower bound (when LBOUND_P is true) or the upper bound (when
174    LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
175    ARRAY (which must be an array).  GDBARCH is the current architecture.  */
176
177 static struct value *
178 fortran_bounds_for_dimension (bool lbound_p,
179                               struct gdbarch *gdbarch,
180                               struct value *array,
181                               struct value *dim_val)
182 {
183   /* Check the requested dimension is valid for this array.  */
184   type *array_type = check_typedef (value_type (array));
185   int ndimensions = calc_f77_array_dims (array_type);
186   long dim = value_as_long (dim_val);
187   if (dim < 1 || dim > ndimensions)
188     {
189       if (lbound_p)
190         error (_("LBOUND dimension must be from 1 to %d"), ndimensions);
191       else
192         error (_("UBOUND dimension must be from 1 to %d"), ndimensions);
193     }
194
195   /* The type for the result.  */
196   struct type *bound_type = builtin_type (gdbarch)->builtin_long_long;
197
198   /* Walk the dimensions backwards, due to the ordering in which arrays are
199      laid out the first dimension is the most inner.  */
200   for (int i = ndimensions - 1; i >= 0; --i)
201     {
202       /* If this is the requested dimension then we're done.  Grab the
203          bounds and return.  */
204       if (i == dim - 1)
205         {
206           LONGEST b;
207
208           if (lbound_p)
209             b = f77_get_lowerbound (array_type);
210           else
211             b = f77_get_upperbound (array_type);
212
213           return value_from_longest (bound_type, b);
214         }
215
216       /* Peel off another dimension of the array.  */
217       array_type = TYPE_TARGET_TYPE (array_type);
218     }
219
220   gdb_assert_not_reached ("failed to find matching dimension");
221 }
222 \f
223
224 /* Return the number of dimensions for a Fortran array or string.  */
225
226 int
227 calc_f77_array_dims (struct type *array_type)
228 {
229   int ndimen = 1;
230   struct type *tmp_type;
231
232   if ((array_type->code () == TYPE_CODE_STRING))
233     return 1;
234
235   if ((array_type->code () != TYPE_CODE_ARRAY))
236     error (_("Can't get dimensions for a non-array type"));
237
238   tmp_type = array_type;
239
240   while ((tmp_type = TYPE_TARGET_TYPE (tmp_type)))
241     {
242       if (tmp_type->code () == TYPE_CODE_ARRAY)
243         ++ndimen;
244     }
245   return ndimen;
246 }
247
248 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
249    slices.  This is a base class for two alternative repacking mechanisms,
250    one for when repacking from a lazy value, and one for repacking from a
251    non-lazy (already loaded) value.  */
252 class fortran_array_repacker_base_impl
253   : public fortran_array_walker_base_impl
254 {
255 public:
256   /* Constructor, DEST is the value we are repacking into.  */
257   fortran_array_repacker_base_impl (struct value *dest)
258     : m_dest (dest),
259       m_dest_offset (0)
260   { /* Nothing.  */ }
261
262   /* When we start processing the inner most dimension, this is where we
263      will be creating values for each element as we load them and then copy
264      them into the M_DEST value.  Set a value mark so we can free these
265      temporary values.  */
266   void start_dimension (bool inner_p)
267   {
268     if (inner_p)
269       {
270         gdb_assert (m_mark == nullptr);
271         m_mark = value_mark ();
272       }
273   }
274
275   /* When we finish processing the inner most dimension free all temporary
276      value that were created.  */
277   void finish_dimension (bool inner_p, bool last_p)
278   {
279     if (inner_p)
280       {
281         gdb_assert (m_mark != nullptr);
282         value_free_to_mark (m_mark);
283         m_mark = nullptr;
284       }
285   }
286
287 protected:
288   /* Copy the contents of array element ELT into M_DEST at the next
289      available offset.  */
290   void copy_element_to_dest (struct value *elt)
291   {
292     value_contents_copy (m_dest, m_dest_offset, elt, 0,
293                          TYPE_LENGTH (value_type (elt)));
294     m_dest_offset += TYPE_LENGTH (value_type (elt));
295   }
296
297   /* The value being written to.  */
298   struct value *m_dest;
299
300   /* The byte offset in M_DEST at which the next element should be
301      written.  */
302   LONGEST m_dest_offset;
303
304   /* Set with a call to VALUE_MARK, and then reset after calling
305      VALUE_FREE_TO_MARK.  */
306   struct value *m_mark = nullptr;
307 };
308
309 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
310    slices.  This class is specialised for repacking an array slice from a
311    lazy array value, as such it does not require the parent array value to
312    be loaded into GDB's memory; the parent value could be huge, while the
313    slice could be tiny.  */
314 class fortran_lazy_array_repacker_impl
315   : public fortran_array_repacker_base_impl
316 {
317 public:
318   /* Constructor.  TYPE is the type of the slice being loaded from the
319      parent value, so this type will correctly reflect the strides required
320      to find all of the elements from the parent value.  ADDRESS is the
321      address in target memory of value matching TYPE, and DEST is the value
322      we are repacking into.  */
323   explicit fortran_lazy_array_repacker_impl (struct type *type,
324                                              CORE_ADDR address,
325                                              struct value *dest)
326     : fortran_array_repacker_base_impl (dest),
327       m_addr (address)
328   { /* Nothing.  */ }
329
330   /* Create a lazy value in target memory representing a single element,
331      then load the element into GDB's memory and copy the contents into the
332      destination value.  */
333   void process_element (struct type *elt_type, LONGEST elt_off, bool last_p)
334   {
335     copy_element_to_dest (value_at_lazy (elt_type, m_addr + elt_off));
336   }
337
338 private:
339   /* The address in target memory where the parent value starts.  */
340   CORE_ADDR m_addr;
341 };
342
343 /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
344    slices.  This class is specialised for repacking an array slice from a
345    previously loaded (non-lazy) array value, as such it fetches the
346    element values from the contents of the parent value.  */
347 class fortran_array_repacker_impl
348   : public fortran_array_repacker_base_impl
349 {
350 public:
351   /* Constructor.  TYPE is the type for the array slice within the parent
352      value, as such it has stride values as required to find the elements
353      within the original parent value.  ADDRESS is the address in target
354      memory of the value matching TYPE.  BASE_OFFSET is the offset from
355      the start of VAL's content buffer to the start of the object of TYPE,
356      VAL is the parent object from which we are loading the value, and
357      DEST is the value into which we are repacking.  */
358   explicit fortran_array_repacker_impl (struct type *type, CORE_ADDR address,
359                                         LONGEST base_offset,
360                                         struct value *val, struct value *dest)
361     : fortran_array_repacker_base_impl (dest),
362       m_base_offset (base_offset),
363       m_val (val)
364   {
365     gdb_assert (!value_lazy (val));
366   }
367
368   /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
369      from the content buffer of M_VAL then copy this extracted value into
370      the repacked destination value.  */
371   void process_element (struct type *elt_type, LONGEST elt_off, bool last_p)
372   {
373     struct value *elt
374       = value_from_component (m_val, elt_type, (elt_off + m_base_offset));
375     copy_element_to_dest (elt);
376   }
377
378 private:
379   /* The offset into the content buffer of M_VAL to the start of the slice
380      being extracted.  */
381   LONGEST m_base_offset;
382
383   /* The parent value from which we are extracting a slice.  */
384   struct value *m_val;
385 };
386
387
388 /* Evaluate FORTRAN_ASSOCIATED expressions.  Both GDBARCH and LANG are
389    extracted from the expression being evaluated.  POINTER is the required
390    first argument to the 'associated' keyword, and TARGET is the optional
391    second argument, this will be nullptr if the user only passed one
392    argument to their use of 'associated'.  */
393
394 static struct value *
395 fortran_associated (struct gdbarch *gdbarch, const language_defn *lang,
396                     struct value *pointer, struct value *target = nullptr)
397 {
398   struct type *result_type = language_bool_type (lang, gdbarch);
399
400   /* All Fortran pointers should have the associated property, this is
401      how we know the pointer is pointing at something or not.  */
402   struct type *pointer_type = check_typedef (value_type (pointer));
403   if (TYPE_ASSOCIATED_PROP (pointer_type) == nullptr
404       && pointer_type->code () != TYPE_CODE_PTR)
405     error (_("ASSOCIATED can only be applied to pointers"));
406
407   /* Get an address from POINTER.  Fortran (or at least gfortran) models
408      array pointers as arrays with a dynamic data address, so we need to
409      use two approaches here, for real pointers we take the contents of the
410      pointer as an address.  For non-pointers we take the address of the
411      content.  */
412   CORE_ADDR pointer_addr;
413   if (pointer_type->code () == TYPE_CODE_PTR)
414     pointer_addr = value_as_address (pointer);
415   else
416     pointer_addr = value_address (pointer);
417
418   /* The single argument case, is POINTER associated with anything?  */
419   if (target == nullptr)
420     {
421       bool is_associated = false;
422
423       /* If POINTER is an actual pointer and doesn't have an associated
424          property then we need to figure out whether this pointer is
425          associated by looking at the value of the pointer itself.  We make
426          the assumption that a non-associated pointer will be set to 0.
427          This is probably true for most targets, but might not be true for
428          everyone.  */
429       if (pointer_type->code () == TYPE_CODE_PTR
430           && TYPE_ASSOCIATED_PROP (pointer_type) == nullptr)
431         is_associated = (pointer_addr != 0);
432       else
433         is_associated = !type_not_associated (pointer_type);
434       return value_from_longest (result_type, is_associated ? 1 : 0);
435     }
436
437   /* The two argument case, is POINTER associated with TARGET?  */
438
439   struct type *target_type = check_typedef (value_type (target));
440
441   struct type *pointer_target_type;
442   if (pointer_type->code () == TYPE_CODE_PTR)
443     pointer_target_type = TYPE_TARGET_TYPE (pointer_type);
444   else
445     pointer_target_type = pointer_type;
446
447   struct type *target_target_type;
448   if (target_type->code () == TYPE_CODE_PTR)
449     target_target_type = TYPE_TARGET_TYPE (target_type);
450   else
451     target_target_type = target_type;
452
453   if (pointer_target_type->code () != target_target_type->code ()
454       || (pointer_target_type->code () != TYPE_CODE_ARRAY
455           && (TYPE_LENGTH (pointer_target_type)
456               != TYPE_LENGTH (target_target_type))))
457     error (_("arguments to associated must be of same type and kind"));
458
459   /* If TARGET is not in memory, or the original pointer is specifically
460      known to be not associated with anything, then the answer is obviously
461      false.  Alternatively, if POINTER is an actual pointer and has no
462      associated property, then we have to check if its associated by
463      looking the value of the pointer itself.  We make the assumption that
464      a non-associated pointer will be set to 0.  This is probably true for
465      most targets, but might not be true for everyone.  */
466   if (value_lval_const (target) != lval_memory
467       || type_not_associated (pointer_type)
468       || (TYPE_ASSOCIATED_PROP (pointer_type) == nullptr
469           && pointer_type->code () == TYPE_CODE_PTR
470           && pointer_addr == 0))
471     return value_from_longest (result_type, 0);
472
473   /* See the comment for POINTER_ADDR above.  */
474   CORE_ADDR target_addr;
475   if (target_type->code () == TYPE_CODE_PTR)
476     target_addr = value_as_address (target);
477   else
478     target_addr = value_address (target);
479
480   /* Wrap the following checks inside a do { ... } while (false) loop so
481      that we can use `break' to jump out of the loop.  */
482   bool is_associated = false;
483   do
484     {
485       /* If the addresses are different then POINTER is definitely not
486          pointing at TARGET.  */
487       if (pointer_addr != target_addr)
488         break;
489
490       /* If POINTER is a real pointer (i.e. not an array pointer, which are
491          implemented as arrays with a dynamic content address), then this
492          is all the checking that is needed.  */
493       if (pointer_type->code () == TYPE_CODE_PTR)
494         {
495           is_associated = true;
496           break;
497         }
498
499       /* We have an array pointer.  Check the number of dimensions.  */
500       int pointer_dims = calc_f77_array_dims (pointer_type);
501       int target_dims = calc_f77_array_dims (target_type);
502       if (pointer_dims != target_dims)
503         break;
504
505       /* Now check that every dimension has the same upper bound, lower
506          bound, and stride value.  */
507       int dim = 0;
508       while (dim < pointer_dims)
509         {
510           LONGEST pointer_lowerbound, pointer_upperbound, pointer_stride;
511           LONGEST target_lowerbound, target_upperbound, target_stride;
512
513           pointer_type = check_typedef (pointer_type);
514           target_type = check_typedef (target_type);
515
516           struct type *pointer_range = pointer_type->index_type ();
517           struct type *target_range = target_type->index_type ();
518
519           if (!get_discrete_bounds (pointer_range, &pointer_lowerbound,
520                                     &pointer_upperbound))
521             break;
522
523           if (!get_discrete_bounds (target_range, &target_lowerbound,
524                                     &target_upperbound))
525             break;
526
527           if (pointer_lowerbound != target_lowerbound
528               || pointer_upperbound != target_upperbound)
529             break;
530
531           /* Figure out the stride (in bits) for both pointer and target.
532              If either doesn't have a stride then we take the element size,
533              but we need to convert to bits (hence the * 8).  */
534           pointer_stride = pointer_range->bounds ()->bit_stride ();
535           if (pointer_stride == 0)
536             pointer_stride
537               = type_length_units (check_typedef
538                                      (TYPE_TARGET_TYPE (pointer_type))) * 8;
539           target_stride = target_range->bounds ()->bit_stride ();
540           if (target_stride == 0)
541             target_stride
542               = type_length_units (check_typedef
543                                      (TYPE_TARGET_TYPE (target_type))) * 8;
544           if (pointer_stride != target_stride)
545             break;
546
547           ++dim;
548         }
549
550       if (dim < pointer_dims)
551         break;
552
553       is_associated = true;
554     }
555   while (false);
556
557   return value_from_longest (result_type, is_associated ? 1 : 0);
558 }
559
560 struct value *
561 eval_op_f_associated (struct type *expect_type,
562                       struct expression *exp,
563                       enum noside noside,
564                       enum exp_opcode opcode,
565                       struct value *arg1)
566 {
567   return fortran_associated (exp->gdbarch, exp->language_defn, arg1);
568 }
569
570 struct value *
571 eval_op_f_associated (struct type *expect_type,
572                       struct expression *exp,
573                       enum noside noside,
574                       enum exp_opcode opcode,
575                       struct value *arg1,
576                       struct value *arg2)
577 {
578   return fortran_associated (exp->gdbarch, exp->language_defn, arg1, arg2);
579 }
580
581 /* A helper function for UNOP_ABS.  */
582
583 struct value *
584 eval_op_f_abs (struct type *expect_type, struct expression *exp,
585                enum noside noside,
586                enum exp_opcode opcode,
587                struct value *arg1)
588 {
589   if (noside == EVAL_SKIP)
590     return eval_skip_value (exp);
591   struct type *type = value_type (arg1);
592   switch (type->code ())
593     {
594     case TYPE_CODE_FLT:
595       {
596         double d
597           = fabs (target_float_to_host_double (value_contents (arg1),
598                                                value_type (arg1)));
599         return value_from_host_double (type, d);
600       }
601     case TYPE_CODE_INT:
602       {
603         LONGEST l = value_as_long (arg1);
604         l = llabs (l);
605         return value_from_longest (type, l);
606       }
607     }
608   error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type));
609 }
610
611 /* A helper function for BINOP_MOD.  */
612
613 struct value *
614 eval_op_f_mod (struct type *expect_type, struct expression *exp,
615                enum noside noside,
616                enum exp_opcode opcode,
617                struct value *arg1, struct value *arg2)
618 {
619   if (noside == EVAL_SKIP)
620     return eval_skip_value (exp);
621   struct type *type = value_type (arg1);
622   if (type->code () != value_type (arg2)->code ())
623     error (_("non-matching types for parameters to MOD ()"));
624   switch (type->code ())
625     {
626     case TYPE_CODE_FLT:
627       {
628         double d1
629           = target_float_to_host_double (value_contents (arg1),
630                                          value_type (arg1));
631         double d2
632           = target_float_to_host_double (value_contents (arg2),
633                                          value_type (arg2));
634         double d3 = fmod (d1, d2);
635         return value_from_host_double (type, d3);
636       }
637     case TYPE_CODE_INT:
638       {
639         LONGEST v1 = value_as_long (arg1);
640         LONGEST v2 = value_as_long (arg2);
641         if (v2 == 0)
642           error (_("calling MOD (N, 0) is undefined"));
643         LONGEST v3 = v1 - (v1 / v2) * v2;
644         return value_from_longest (value_type (arg1), v3);
645       }
646     }
647   error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
648 }
649
650 /* A helper function for UNOP_FORTRAN_CEILING.  */
651
652 struct value *
653 eval_op_f_ceil (struct type *expect_type, struct expression *exp,
654                 enum noside noside,
655                 enum exp_opcode opcode,
656                 struct value *arg1)
657 {
658   if (noside == EVAL_SKIP)
659     return eval_skip_value (exp);
660   struct type *type = value_type (arg1);
661   if (type->code () != TYPE_CODE_FLT)
662     error (_("argument to CEILING must be of type float"));
663   double val
664     = target_float_to_host_double (value_contents (arg1),
665                                    value_type (arg1));
666   val = ceil (val);
667   return value_from_host_double (type, val);
668 }
669
670 /* A helper function for UNOP_FORTRAN_FLOOR.  */
671
672 struct value *
673 eval_op_f_floor (struct type *expect_type, struct expression *exp,
674                  enum noside noside,
675                  enum exp_opcode opcode,
676                  struct value *arg1)
677 {
678   if (noside == EVAL_SKIP)
679     return eval_skip_value (exp);
680   struct type *type = value_type (arg1);
681   if (type->code () != TYPE_CODE_FLT)
682     error (_("argument to FLOOR must be of type float"));
683   double val
684     = target_float_to_host_double (value_contents (arg1),
685                                    value_type (arg1));
686   val = floor (val);
687   return value_from_host_double (type, val);
688 }
689
690 /* A helper function for BINOP_FORTRAN_MODULO.  */
691
692 struct value *
693 eval_op_f_modulo (struct type *expect_type, struct expression *exp,
694                   enum noside noside,
695                   enum exp_opcode opcode,
696                   struct value *arg1, struct value *arg2)
697 {
698   if (noside == EVAL_SKIP)
699     return eval_skip_value (exp);
700   struct type *type = value_type (arg1);
701   if (type->code () != value_type (arg2)->code ())
702     error (_("non-matching types for parameters to MODULO ()"));
703   /* MODULO(A, P) = A - FLOOR (A / P) * P */
704   switch (type->code ())
705     {
706     case TYPE_CODE_INT:
707       {
708         LONGEST a = value_as_long (arg1);
709         LONGEST p = value_as_long (arg2);
710         LONGEST result = a - (a / p) * p;
711         if (result != 0 && (a < 0) != (p < 0))
712           result += p;
713         return value_from_longest (value_type (arg1), result);
714       }
715     case TYPE_CODE_FLT:
716       {
717         double a
718           = target_float_to_host_double (value_contents (arg1),
719                                          value_type (arg1));
720         double p
721           = target_float_to_host_double (value_contents (arg2),
722                                          value_type (arg2));
723         double result = fmod (a, p);
724         if (result != 0 && (a < 0.0) != (p < 0.0))
725           result += p;
726         return value_from_host_double (type, result);
727       }
728     }
729   error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
730 }
731
732 /* A helper function for BINOP_FORTRAN_CMPLX.  */
733
734 struct value *
735 eval_op_f_cmplx (struct type *expect_type, struct expression *exp,
736                  enum noside noside,
737                  enum exp_opcode opcode,
738                  struct value *arg1, struct value *arg2)
739 {
740   if (noside == EVAL_SKIP)
741     return eval_skip_value (exp);
742   struct type *type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
743   return value_literal_complex (arg1, arg2, type);
744 }
745
746 /* A helper function for UNOP_FORTRAN_KIND.  */
747
748 struct value *
749 eval_op_f_kind (struct type *expect_type, struct expression *exp,
750                 enum noside noside,
751                 enum exp_opcode opcode,
752                 struct value *arg1)
753 {
754   struct type *type = value_type (arg1);
755
756   switch (type->code ())
757     {
758     case TYPE_CODE_STRUCT:
759     case TYPE_CODE_UNION:
760     case TYPE_CODE_MODULE:
761     case TYPE_CODE_FUNC:
762       error (_("argument to kind must be an intrinsic type"));
763     }
764
765   if (!TYPE_TARGET_TYPE (type))
766     return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
767                                TYPE_LENGTH (type));
768   return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
769                              TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
770 }
771
772 /* A helper function for UNOP_FORTRAN_ALLOCATED.  */
773
774 struct value *
775 eval_op_f_allocated (struct type *expect_type, struct expression *exp,
776                      enum noside noside, enum exp_opcode op,
777                      struct value *arg1)
778 {
779   struct type *type = check_typedef (value_type (arg1));
780   if (type->code () != TYPE_CODE_ARRAY)
781     error (_("ALLOCATED can only be applied to arrays"));
782   struct type *result_type
783     = builtin_f_type (exp->gdbarch)->builtin_logical;
784   LONGEST result_value = type_not_allocated (type) ? 0 : 1;
785   return value_from_longest (result_type, result_value);
786 }
787
788 namespace expr
789 {
790
791 /* Called from evaluate to perform array indexing, and sub-range
792    extraction, for Fortran.  As well as arrays this function also
793    handles strings as they can be treated like arrays of characters.
794    ARRAY is the array or string being accessed.  EXP and NOSIDE are as
795    for evaluate.  */
796
797 value *
798 fortran_undetermined::value_subarray (value *array,
799                                       struct expression *exp,
800                                       enum noside noside)
801 {
802   type *original_array_type = check_typedef (value_type (array));
803   bool is_string_p = original_array_type->code () == TYPE_CODE_STRING;
804   const std::vector<operation_up> &ops = std::get<1> (m_storage);
805   int nargs = ops.size ();
806
807   /* Perform checks for ARRAY not being available.  The somewhat overly
808      complex logic here is just to keep backward compatibility with the
809      errors that we used to get before FORTRAN_VALUE_SUBARRAY was
810      rewritten.  Maybe a future task would streamline the error messages we
811      get here, and update all the expected test results.  */
812   if (ops[0]->opcode () != OP_RANGE)
813     {
814       if (type_not_associated (original_array_type))
815         error (_("no such vector element (vector not associated)"));
816       else if (type_not_allocated (original_array_type))
817         error (_("no such vector element (vector not allocated)"));
818     }
819   else
820     {
821       if (type_not_associated (original_array_type))
822         error (_("array not associated"));
823       else if (type_not_allocated (original_array_type))
824         error (_("array not allocated"));
825     }
826
827   /* First check that the number of dimensions in the type we are slicing
828      matches the number of arguments we were passed.  */
829   int ndimensions = calc_f77_array_dims (original_array_type);
830   if (nargs != ndimensions)
831     error (_("Wrong number of subscripts"));
832
833   /* This will be initialised below with the type of the elements held in
834      ARRAY.  */
835   struct type *inner_element_type;
836
837   /* Extract the types of each array dimension from the original array
838      type.  We need these available so we can fill in the default upper and
839      lower bounds if the user requested slice doesn't provide that
840      information.  Additionally unpacking the dimensions like this gives us
841      the inner element type.  */
842   std::vector<struct type *> dim_types;
843   {
844     dim_types.reserve (ndimensions);
845     struct type *type = original_array_type;
846     for (int i = 0; i < ndimensions; ++i)
847       {
848         dim_types.push_back (type);
849         type = TYPE_TARGET_TYPE (type);
850       }
851     /* TYPE is now the inner element type of the array, we start the new
852        array slice off as this type, then as we process the requested slice
853        (from the user) we wrap new types around this to build up the final
854        slice type.  */
855     inner_element_type = type;
856   }
857
858   /* As we analyse the new slice type we need to understand if the data
859      being referenced is contiguous.  Do decide this we must track the size
860      of an element at each dimension of the new slice array.  Initially the
861      elements of the inner most dimension of the array are the same inner
862      most elements as the original ARRAY.  */
863   LONGEST slice_element_size = TYPE_LENGTH (inner_element_type);
864
865   /* Start off assuming all data is contiguous, this will be set to false
866      if access to any dimension results in non-contiguous data.  */
867   bool is_all_contiguous = true;
868
869   /* The TOTAL_OFFSET is the distance in bytes from the start of the
870      original ARRAY to the start of the new slice.  This is calculated as
871      we process the information from the user.  */
872   LONGEST total_offset = 0;
873
874   /* A structure representing information about each dimension of the
875      resulting slice.  */
876   struct slice_dim
877   {
878     /* Constructor.  */
879     slice_dim (LONGEST l, LONGEST h, LONGEST s, struct type *idx)
880       : low (l),
881         high (h),
882         stride (s),
883         index (idx)
884     { /* Nothing.  */ }
885
886     /* The low bound for this dimension of the slice.  */
887     LONGEST low;
888
889     /* The high bound for this dimension of the slice.  */
890     LONGEST high;
891
892     /* The byte stride for this dimension of the slice.  */
893     LONGEST stride;
894
895     struct type *index;
896   };
897
898   /* The dimensions of the resulting slice.  */
899   std::vector<slice_dim> slice_dims;
900
901   /* Process the incoming arguments.   These arguments are in the reverse
902      order to the array dimensions, that is the first argument refers to
903      the last array dimension.  */
904   if (fortran_array_slicing_debug)
905     debug_printf ("Processing array access:\n");
906   for (int i = 0; i < nargs; ++i)
907     {
908       /* For each dimension of the array the user will have either provided
909          a ranged access with optional lower bound, upper bound, and
910          stride, or the user will have supplied a single index.  */
911       struct type *dim_type = dim_types[ndimensions - (i + 1)];
912       fortran_range_operation *range_op
913         = dynamic_cast<fortran_range_operation *> (ops[i].get ());
914       if (range_op != nullptr)
915         {
916           enum range_flag range_flag = range_op->get_flags ();
917
918           LONGEST low, high, stride;
919           low = high = stride = 0;
920
921           if ((range_flag & RANGE_LOW_BOUND_DEFAULT) == 0)
922             low = value_as_long (range_op->evaluate0 (exp, noside));
923           else
924             low = f77_get_lowerbound (dim_type);
925           if ((range_flag & RANGE_HIGH_BOUND_DEFAULT) == 0)
926             high = value_as_long (range_op->evaluate1 (exp, noside));
927           else
928             high = f77_get_upperbound (dim_type);
929           if ((range_flag & RANGE_HAS_STRIDE) == RANGE_HAS_STRIDE)
930             stride = value_as_long (range_op->evaluate2 (exp, noside));
931           else
932             stride = 1;
933
934           if (stride == 0)
935             error (_("stride must not be 0"));
936
937           /* Get information about this dimension in the original ARRAY.  */
938           struct type *target_type = TYPE_TARGET_TYPE (dim_type);
939           struct type *index_type = dim_type->index_type ();
940           LONGEST lb = f77_get_lowerbound (dim_type);
941           LONGEST ub = f77_get_upperbound (dim_type);
942           LONGEST sd = index_type->bit_stride ();
943           if (sd == 0)
944             sd = TYPE_LENGTH (target_type) * 8;
945
946           if (fortran_array_slicing_debug)
947             {
948               debug_printf ("|-> Range access\n");
949               std::string str = type_to_string (dim_type);
950               debug_printf ("|   |-> Type: %s\n", str.c_str ());
951               debug_printf ("|   |-> Array:\n");
952               debug_printf ("|   |   |-> Low bound: %s\n", plongest (lb));
953               debug_printf ("|   |   |-> High bound: %s\n", plongest (ub));
954               debug_printf ("|   |   |-> Bit stride: %s\n", plongest (sd));
955               debug_printf ("|   |   |-> Byte stride: %s\n", plongest (sd / 8));
956               debug_printf ("|   |   |-> Type size: %s\n",
957                             pulongest (TYPE_LENGTH (dim_type)));
958               debug_printf ("|   |   '-> Target type size: %s\n",
959                             pulongest (TYPE_LENGTH (target_type)));
960               debug_printf ("|   |-> Accessing:\n");
961               debug_printf ("|   |   |-> Low bound: %s\n",
962                             plongest (low));
963               debug_printf ("|   |   |-> High bound: %s\n",
964                             plongest (high));
965               debug_printf ("|   |   '-> Element stride: %s\n",
966                             plongest (stride));
967             }
968
969           /* Check the user hasn't asked for something invalid.  */
970           if (high > ub || low < lb)
971             error (_("array subscript out of bounds"));
972
973           /* Calculate what this dimension of the new slice array will look
974              like.  OFFSET is the byte offset from the start of the
975              previous (more outer) dimension to the start of this
976              dimension.  E_COUNT is the number of elements in this
977              dimension.  REMAINDER is the number of elements remaining
978              between the last included element and the upper bound.  For
979              example an access '1:6:2' will include elements 1, 3, 5 and
980              have a remainder of 1 (element #6).  */
981           LONGEST lowest = std::min (low, high);
982           LONGEST offset = (sd / 8) * (lowest - lb);
983           LONGEST e_count = std::abs (high - low) + 1;
984           e_count = (e_count + (std::abs (stride) - 1)) / std::abs (stride);
985           LONGEST new_low = 1;
986           LONGEST new_high = new_low + e_count - 1;
987           LONGEST new_stride = (sd * stride) / 8;
988           LONGEST last_elem = low + ((e_count - 1) * stride);
989           LONGEST remainder = high - last_elem;
990           if (low > high)
991             {
992               offset += std::abs (remainder) * TYPE_LENGTH (target_type);
993               if (stride > 0)
994                 error (_("incorrect stride and boundary combination"));
995             }
996           else if (stride < 0)
997             error (_("incorrect stride and boundary combination"));
998
999           /* Is the data within this dimension contiguous?  It is if the
1000              newly computed stride is the same size as a single element of
1001              this dimension.  */
1002           bool is_dim_contiguous = (new_stride == slice_element_size);
1003           is_all_contiguous &= is_dim_contiguous;
1004
1005           if (fortran_array_slicing_debug)
1006             {
1007               debug_printf ("|   '-> Results:\n");
1008               debug_printf ("|       |-> Offset = %s\n", plongest (offset));
1009               debug_printf ("|       |-> Elements = %s\n", plongest (e_count));
1010               debug_printf ("|       |-> Low bound = %s\n", plongest (new_low));
1011               debug_printf ("|       |-> High bound = %s\n",
1012                             plongest (new_high));
1013               debug_printf ("|       |-> Byte stride = %s\n",
1014                             plongest (new_stride));
1015               debug_printf ("|       |-> Last element = %s\n",
1016                             plongest (last_elem));
1017               debug_printf ("|       |-> Remainder = %s\n",
1018                             plongest (remainder));
1019               debug_printf ("|       '-> Contiguous = %s\n",
1020                             (is_dim_contiguous ? "Yes" : "No"));
1021             }
1022
1023           /* Figure out how big (in bytes) an element of this dimension of
1024              the new array slice will be.  */
1025           slice_element_size = std::abs (new_stride * e_count);
1026
1027           slice_dims.emplace_back (new_low, new_high, new_stride,
1028                                    index_type);
1029
1030           /* Update the total offset.  */
1031           total_offset += offset;
1032         }
1033       else
1034         {
1035           /* There is a single index for this dimension.  */
1036           LONGEST index
1037             = value_as_long (ops[i]->evaluate_with_coercion (exp, noside));
1038
1039           /* Get information about this dimension in the original ARRAY.  */
1040           struct type *target_type = TYPE_TARGET_TYPE (dim_type);
1041           struct type *index_type = dim_type->index_type ();
1042           LONGEST lb = f77_get_lowerbound (dim_type);
1043           LONGEST ub = f77_get_upperbound (dim_type);
1044           LONGEST sd = index_type->bit_stride () / 8;
1045           if (sd == 0)
1046             sd = TYPE_LENGTH (target_type);
1047
1048           if (fortran_array_slicing_debug)
1049             {
1050               debug_printf ("|-> Index access\n");
1051               std::string str = type_to_string (dim_type);
1052               debug_printf ("|   |-> Type: %s\n", str.c_str ());
1053               debug_printf ("|   |-> Array:\n");
1054               debug_printf ("|   |   |-> Low bound: %s\n", plongest (lb));
1055               debug_printf ("|   |   |-> High bound: %s\n", plongest (ub));
1056               debug_printf ("|   |   |-> Byte stride: %s\n", plongest (sd));
1057               debug_printf ("|   |   |-> Type size: %s\n",
1058                             pulongest (TYPE_LENGTH (dim_type)));
1059               debug_printf ("|   |   '-> Target type size: %s\n",
1060                             pulongest (TYPE_LENGTH (target_type)));
1061               debug_printf ("|   '-> Accessing:\n");
1062               debug_printf ("|       '-> Index: %s\n",
1063                             plongest (index));
1064             }
1065
1066           /* If the array has actual content then check the index is in
1067              bounds.  An array without content (an unbound array) doesn't
1068              have a known upper bound, so don't error check in that
1069              situation.  */
1070           if (index < lb
1071               || (dim_type->index_type ()->bounds ()->high.kind () != PROP_UNDEFINED
1072                   && index > ub)
1073               || (VALUE_LVAL (array) != lval_memory
1074                   && dim_type->index_type ()->bounds ()->high.kind () == PROP_UNDEFINED))
1075             {
1076               if (type_not_associated (dim_type))
1077                 error (_("no such vector element (vector not associated)"));
1078               else if (type_not_allocated (dim_type))
1079                 error (_("no such vector element (vector not allocated)"));
1080               else
1081                 error (_("no such vector element"));
1082             }
1083
1084           /* Calculate using the type stride, not the target type size.  */
1085           LONGEST offset = sd * (index - lb);
1086           total_offset += offset;
1087         }
1088     }
1089
1090   /* Build a type that represents the new array slice in the target memory
1091      of the original ARRAY, this type makes use of strides to correctly
1092      find only those elements that are part of the new slice.  */
1093   struct type *array_slice_type = inner_element_type;
1094   for (const auto &d : slice_dims)
1095     {
1096       /* Create the range.  */
1097       dynamic_prop p_low, p_high, p_stride;
1098
1099       p_low.set_const_val (d.low);
1100       p_high.set_const_val (d.high);
1101       p_stride.set_const_val (d.stride);
1102
1103       struct type *new_range
1104         = create_range_type_with_stride ((struct type *) NULL,
1105                                          TYPE_TARGET_TYPE (d.index),
1106                                          &p_low, &p_high, 0, &p_stride,
1107                                          true);
1108       array_slice_type
1109         = create_array_type (nullptr, array_slice_type, new_range);
1110     }
1111
1112   if (fortran_array_slicing_debug)
1113     {
1114       debug_printf ("'-> Final result:\n");
1115       debug_printf ("    |-> Type: %s\n",
1116                     type_to_string (array_slice_type).c_str ());
1117       debug_printf ("    |-> Total offset: %s\n",
1118                     plongest (total_offset));
1119       debug_printf ("    |-> Base address: %s\n",
1120                     core_addr_to_string (value_address (array)));
1121       debug_printf ("    '-> Contiguous = %s\n",
1122                     (is_all_contiguous ? "Yes" : "No"));
1123     }
1124
1125   /* Should we repack this array slice?  */
1126   if (!is_all_contiguous && (repack_array_slices || is_string_p))
1127     {
1128       /* Build a type for the repacked slice.  */
1129       struct type *repacked_array_type = inner_element_type;
1130       for (const auto &d : slice_dims)
1131         {
1132           /* Create the range.  */
1133           dynamic_prop p_low, p_high, p_stride;
1134
1135           p_low.set_const_val (d.low);
1136           p_high.set_const_val (d.high);
1137           p_stride.set_const_val (TYPE_LENGTH (repacked_array_type));
1138
1139           struct type *new_range
1140             = create_range_type_with_stride ((struct type *) NULL,
1141                                              TYPE_TARGET_TYPE (d.index),
1142                                              &p_low, &p_high, 0, &p_stride,
1143                                              true);
1144           repacked_array_type
1145             = create_array_type (nullptr, repacked_array_type, new_range);
1146         }
1147
1148       /* Now copy the elements from the original ARRAY into the packed
1149          array value DEST.  */
1150       struct value *dest = allocate_value (repacked_array_type);
1151       if (value_lazy (array)
1152           || (total_offset + TYPE_LENGTH (array_slice_type)
1153               > TYPE_LENGTH (check_typedef (value_type (array)))))
1154         {
1155           fortran_array_walker<fortran_lazy_array_repacker_impl> p
1156             (array_slice_type, value_address (array) + total_offset, dest);
1157           p.walk ();
1158         }
1159       else
1160         {
1161           fortran_array_walker<fortran_array_repacker_impl> p
1162             (array_slice_type, value_address (array) + total_offset,
1163              total_offset, array, dest);
1164           p.walk ();
1165         }
1166       array = dest;
1167     }
1168   else
1169     {
1170       if (VALUE_LVAL (array) == lval_memory)
1171         {
1172           /* If the value we're taking a slice from is not yet loaded, or
1173              the requested slice is outside the values content range then
1174              just create a new lazy value pointing at the memory where the
1175              contents we're looking for exist.  */
1176           if (value_lazy (array)
1177               || (total_offset + TYPE_LENGTH (array_slice_type)
1178                   > TYPE_LENGTH (check_typedef (value_type (array)))))
1179             array = value_at_lazy (array_slice_type,
1180                                    value_address (array) + total_offset);
1181           else
1182             array = value_from_contents_and_address (array_slice_type,
1183                                                      (value_contents (array)
1184                                                       + total_offset),
1185                                                      (value_address (array)
1186                                                       + total_offset));
1187         }
1188       else if (!value_lazy (array))
1189         array = value_from_component (array, array_slice_type, total_offset);
1190       else
1191         error (_("cannot subscript arrays that are not in memory"));
1192     }
1193
1194   return array;
1195 }
1196
1197 value *
1198 fortran_undetermined::evaluate (struct type *expect_type,
1199                                 struct expression *exp,
1200                                 enum noside noside)
1201 {
1202   value *callee = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
1203   struct type *type = check_typedef (value_type (callee));
1204   enum type_code code = type->code ();
1205
1206   if (code == TYPE_CODE_PTR)
1207     {
1208       /* Fortran always passes variable to subroutines as pointer.
1209          So we need to look into its target type to see if it is
1210          array, string or function.  If it is, we need to switch
1211          to the target value the original one points to.  */
1212       struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
1213
1214       if (target_type->code () == TYPE_CODE_ARRAY
1215           || target_type->code () == TYPE_CODE_STRING
1216           || target_type->code () == TYPE_CODE_FUNC)
1217         {
1218           callee = value_ind (callee);
1219           type = check_typedef (value_type (callee));
1220           code = type->code ();
1221         }
1222     }
1223
1224   switch (code)
1225     {
1226     case TYPE_CODE_ARRAY:
1227     case TYPE_CODE_STRING:
1228       return value_subarray (callee, exp, noside);
1229
1230     case TYPE_CODE_PTR:
1231     case TYPE_CODE_FUNC:
1232     case TYPE_CODE_INTERNAL_FUNCTION:
1233       {
1234         /* It's a function call.  Allocate arg vector, including
1235            space for the function to be called in argvec[0] and a
1236            termination NULL.  */
1237         const std::vector<operation_up> &actual (std::get<1> (m_storage));
1238         std::vector<value *> argvec (actual.size ());
1239         bool is_internal_func = (code == TYPE_CODE_INTERNAL_FUNCTION);
1240         for (int tem = 0; tem < argvec.size (); tem++)
1241           argvec[tem] = fortran_prepare_argument (exp, actual[tem].get (),
1242                                                   tem, is_internal_func,
1243                                                   value_type (callee),
1244                                                   noside);
1245         return evaluate_subexp_do_call (exp, noside, callee, argvec,
1246                                         nullptr, expect_type);
1247       }
1248
1249     default:
1250       error (_("Cannot perform substring on this type"));
1251     }
1252 }
1253
1254 value *
1255 fortran_bound_1arg::evaluate (struct type *expect_type,
1256                               struct expression *exp,
1257                               enum noside noside)
1258 {
1259   bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
1260   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
1261   fortran_require_array (value_type (arg1), lbound_p);
1262   return fortran_bounds_all_dims (lbound_p, exp->gdbarch, arg1);
1263 }
1264
1265 value *
1266 fortran_bound_2arg::evaluate (struct type *expect_type,
1267                               struct expression *exp,
1268                               enum noside noside)
1269 {
1270   bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
1271   value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
1272   fortran_require_array (value_type (arg1), lbound_p);
1273
1274   /* User asked for the bounds of a specific dimension of the array.  */
1275   value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
1276   struct type *type = check_typedef (value_type (arg2));
1277   if (type->code () != TYPE_CODE_INT)
1278     {
1279       if (lbound_p)
1280         error (_("LBOUND second argument should be an integer"));
1281       else
1282         error (_("UBOUND second argument should be an integer"));
1283     }
1284
1285   return fortran_bounds_for_dimension (lbound_p, exp->gdbarch, arg1, arg2);
1286 }
1287
1288 } /* namespace expr */
1289
1290 /* See language.h.  */
1291
1292 void
1293 f_language::language_arch_info (struct gdbarch *gdbarch,
1294                                 struct language_arch_info *lai) const
1295 {
1296   const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
1297
1298   /* Helper function to allow shorter lines below.  */
1299   auto add  = [&] (struct type * t)
1300   {
1301     lai->add_primitive_type (t);
1302   };
1303
1304   add (builtin->builtin_character);
1305   add (builtin->builtin_logical);
1306   add (builtin->builtin_logical_s1);
1307   add (builtin->builtin_logical_s2);
1308   add (builtin->builtin_logical_s8);
1309   add (builtin->builtin_real);
1310   add (builtin->builtin_real_s8);
1311   add (builtin->builtin_real_s16);
1312   add (builtin->builtin_complex_s8);
1313   add (builtin->builtin_complex_s16);
1314   add (builtin->builtin_void);
1315
1316   lai->set_string_char_type (builtin->builtin_character);
1317   lai->set_bool_type (builtin->builtin_logical_s2, "logical");
1318 }
1319
1320 /* See language.h.  */
1321
1322 unsigned int
1323 f_language::search_name_hash (const char *name) const
1324 {
1325   return cp_search_name_hash (name);
1326 }
1327
1328 /* See language.h.  */
1329
1330 struct block_symbol
1331 f_language::lookup_symbol_nonlocal (const char *name,
1332                                     const struct block *block,
1333                                     const domain_enum domain) const
1334 {
1335   return cp_lookup_symbol_nonlocal (this, name, block, domain);
1336 }
1337
1338 /* See language.h.  */
1339
1340 symbol_name_matcher_ftype *
1341 f_language::get_symbol_name_matcher_inner
1342         (const lookup_name_info &lookup_name) const
1343 {
1344   return cp_get_symbol_name_matcher (lookup_name);
1345 }
1346
1347 /* Single instance of the Fortran language class.  */
1348
1349 static f_language f_language_defn;
1350
1351 static void *
1352 build_fortran_types (struct gdbarch *gdbarch)
1353 {
1354   struct builtin_f_type *builtin_f_type
1355     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
1356
1357   builtin_f_type->builtin_void
1358     = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
1359
1360   builtin_f_type->builtin_character
1361     = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
1362
1363   builtin_f_type->builtin_logical_s1
1364     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
1365
1366   builtin_f_type->builtin_integer_s2
1367     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
1368                          "integer*2");
1369
1370   builtin_f_type->builtin_integer_s8
1371     = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
1372                          "integer*8");
1373
1374   builtin_f_type->builtin_logical_s2
1375     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
1376                          "logical*2");
1377
1378   builtin_f_type->builtin_logical_s8
1379     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
1380                          "logical*8");
1381
1382   builtin_f_type->builtin_integer
1383     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
1384                          "integer");
1385
1386   builtin_f_type->builtin_logical
1387     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
1388                          "logical*4");
1389
1390   builtin_f_type->builtin_real
1391     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
1392                        "real", gdbarch_float_format (gdbarch));
1393   builtin_f_type->builtin_real_s8
1394     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
1395                        "real*8", gdbarch_double_format (gdbarch));
1396   auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
1397   if (fmt != nullptr)
1398     builtin_f_type->builtin_real_s16
1399       = arch_float_type (gdbarch, 128, "real*16", fmt);
1400   else if (gdbarch_long_double_bit (gdbarch) == 128)
1401     builtin_f_type->builtin_real_s16
1402       = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
1403                          "real*16", gdbarch_long_double_format (gdbarch));
1404   else
1405     builtin_f_type->builtin_real_s16
1406       = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
1407
1408   builtin_f_type->builtin_complex_s8
1409     = init_complex_type ("complex*8", builtin_f_type->builtin_real);
1410   builtin_f_type->builtin_complex_s16
1411     = init_complex_type ("complex*16", builtin_f_type->builtin_real_s8);
1412
1413   if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR)
1414     builtin_f_type->builtin_complex_s32
1415       = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*32");
1416   else
1417     builtin_f_type->builtin_complex_s32
1418       = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
1419
1420   return builtin_f_type;
1421 }
1422
1423 static struct gdbarch_data *f_type_data;
1424
1425 const struct builtin_f_type *
1426 builtin_f_type (struct gdbarch *gdbarch)
1427 {
1428   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
1429 }
1430
1431 /* Command-list for the "set/show fortran" prefix command.  */
1432 static struct cmd_list_element *set_fortran_list;
1433 static struct cmd_list_element *show_fortran_list;
1434
1435 void _initialize_f_language ();
1436 void
1437 _initialize_f_language ()
1438 {
1439   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
1440
1441   add_basic_prefix_cmd ("fortran", no_class,
1442                         _("Prefix command for changing Fortran-specific settings."),
1443                         &set_fortran_list, "set fortran ", 0, &setlist);
1444
1445   add_show_prefix_cmd ("fortran", no_class,
1446                        _("Generic command for showing Fortran-specific settings."),
1447                        &show_fortran_list, "show fortran ", 0, &showlist);
1448
1449   add_setshow_boolean_cmd ("repack-array-slices", class_vars,
1450                            &repack_array_slices, _("\
1451 Enable or disable repacking of non-contiguous array slices."), _("\
1452 Show whether non-contiguous array slices are repacked."), _("\
1453 When the user requests a slice of a Fortran array then we can either return\n\
1454 a descriptor that describes the array in place (using the original array data\n\
1455 in its existing location) or the original data can be repacked (copied) to a\n\
1456 new location.\n\
1457 \n\
1458 When the content of the array slice is contiguous within the original array\n\
1459 then the result will never be repacked, but when the data for the new array\n\
1460 is non-contiguous within the original array repacking will only be performed\n\
1461 when this setting is on."),
1462                            NULL,
1463                            show_repack_array_slices,
1464                            &set_fortran_list, &show_fortran_list);
1465
1466   /* Debug Fortran's array slicing logic.  */
1467   add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance,
1468                            &fortran_array_slicing_debug, _("\
1469 Set debugging of Fortran array slicing."), _("\
1470 Show debugging of Fortran array slicing."), _("\
1471 When on, debugging of Fortran array slicing is enabled."),
1472                             NULL,
1473                             show_fortran_array_slicing_debug,
1474                             &setdebuglist, &showdebuglist);
1475 }
1476
1477 /* Ensures that function argument VALUE is in the appropriate form to
1478    pass to a Fortran function.  Returns a possibly new value that should
1479    be used instead of VALUE.
1480
1481    When IS_ARTIFICIAL is true this indicates an artificial argument,
1482    e.g. hidden string lengths which the GNU Fortran argument passing
1483    convention specifies as being passed by value.
1484
1485    When IS_ARTIFICIAL is false, the argument is passed by pointer.  If the
1486    value is already in target memory then return a value that is a pointer
1487    to VALUE.  If VALUE is not in memory (e.g. an integer literal), allocate
1488    space in the target, copy VALUE in, and return a pointer to the in
1489    memory copy.  */
1490
1491 static struct value *
1492 fortran_argument_convert (struct value *value, bool is_artificial)
1493 {
1494   if (!is_artificial)
1495     {
1496       /* If the value is not in the inferior e.g. registers values,
1497          convenience variables and user input.  */
1498       if (VALUE_LVAL (value) != lval_memory)
1499         {
1500           struct type *type = value_type (value);
1501           const int length = TYPE_LENGTH (type);
1502           const CORE_ADDR addr
1503             = value_as_long (value_allocate_space_in_inferior (length));
1504           write_memory (addr, value_contents (value), length);
1505           struct value *val
1506             = value_from_contents_and_address (type, value_contents (value),
1507                                                addr);
1508           return value_addr (val);
1509         }
1510       else
1511         return value_addr (value); /* Program variables, e.g. arrays.  */
1512     }
1513     return value;
1514 }
1515
1516 /* Prepare (and return) an argument value ready for an inferior function
1517    call to a Fortran function.  EXP and POS are the expressions describing
1518    the argument to prepare.  ARG_NUM is the argument number being
1519    prepared, with 0 being the first argument and so on.  FUNC_TYPE is the
1520    type of the function being called.
1521
1522    IS_INTERNAL_CALL_P is true if this is a call to a function of type
1523    TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
1524
1525    NOSIDE has its usual meaning for expression parsing (see eval.c).
1526
1527    Arguments in Fortran are normally passed by address, we coerce the
1528    arguments here rather than in value_arg_coerce as otherwise the call to
1529    malloc (to place the non-lvalue parameters in target memory) is hit by
1530    this Fortran specific logic.  This results in malloc being called with a
1531    pointer to an integer followed by an attempt to malloc the arguments to
1532    malloc in target memory.  Infinite recursion ensues.  */
1533
1534 static value *
1535 fortran_prepare_argument (struct expression *exp,
1536                           expr::operation *subexp,
1537                           int arg_num, bool is_internal_call_p,
1538                           struct type *func_type, enum noside noside)
1539 {
1540   if (is_internal_call_p)
1541     return subexp->evaluate_with_coercion (exp, noside);
1542
1543   bool is_artificial = ((arg_num >= func_type->num_fields ())
1544                         ? true
1545                         : TYPE_FIELD_ARTIFICIAL (func_type, arg_num));
1546
1547   /* If this is an artificial argument, then either, this is an argument
1548      beyond the end of the known arguments, or possibly, there are no known
1549      arguments (maybe missing debug info).
1550
1551      For these artificial arguments, if the user has prefixed it with '&'
1552      (for address-of), then lets always allow this to succeed, even if the
1553      argument is not actually in inferior memory.  This will allow the user
1554      to pass arguments to a Fortran function even when there's no debug
1555      information.
1556
1557      As we already pass the address of non-artificial arguments, all we
1558      need to do if skip the UNOP_ADDR operator in the expression and mark
1559      the argument as non-artificial.  */
1560   if (is_artificial)
1561     {
1562       expr::unop_addr_operation *addrop
1563         = dynamic_cast<expr::unop_addr_operation *> (subexp);
1564       if (addrop != nullptr)
1565         {
1566           subexp = addrop->get_expression ().get ();
1567           is_artificial = false;
1568         }
1569     }
1570
1571   struct value *arg_val = subexp->evaluate_with_coercion (exp, noside);
1572   return fortran_argument_convert (arg_val, is_artificial);
1573 }
1574
1575 /* See f-lang.h.  */
1576
1577 struct type *
1578 fortran_preserve_arg_pointer (struct value *arg, struct type *type)
1579 {
1580   if (value_type (arg)->code () == TYPE_CODE_PTR)
1581     return value_type (arg);
1582   return type;
1583 }
1584
1585 /* See f-lang.h.  */
1586
1587 CORE_ADDR
1588 fortran_adjust_dynamic_array_base_address_hack (struct type *type,
1589                                                 CORE_ADDR address)
1590 {
1591   gdb_assert (type->code () == TYPE_CODE_ARRAY);
1592
1593   /* We can't adjust the base address for arrays that have no content.  */
1594   if (type_not_allocated (type) || type_not_associated (type))
1595     return address;
1596
1597   int ndimensions = calc_f77_array_dims (type);
1598   LONGEST total_offset = 0;
1599
1600   /* Walk through each of the dimensions of this array type and figure out
1601      if any of the dimensions are "backwards", that is the base address
1602      for this dimension points to the element at the highest memory
1603      address and the stride is negative.  */
1604   struct type *tmp_type = type;
1605   for (int i = 0 ; i < ndimensions; ++i)
1606     {
1607       /* Grab the range for this dimension and extract the lower and upper
1608          bounds.  */
1609       tmp_type = check_typedef (tmp_type);
1610       struct type *range_type = tmp_type->index_type ();
1611       LONGEST lowerbound, upperbound, stride;
1612       if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
1613         error ("failed to get range bounds");
1614
1615       /* Figure out the stride for this dimension.  */
1616       struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (tmp_type));
1617       stride = tmp_type->index_type ()->bounds ()->bit_stride ();
1618       if (stride == 0)
1619         stride = type_length_units (elt_type);
1620       else
1621         {
1622           int unit_size
1623             = gdbarch_addressable_memory_unit_size (elt_type->arch ());
1624           stride /= (unit_size * 8);
1625         }
1626
1627       /* If this dimension is "backward" then figure out the offset
1628          adjustment required to point to the element at the lowest memory
1629          address, and add this to the total offset.  */
1630       LONGEST offset = 0;
1631       if (stride < 0 && lowerbound < upperbound)
1632         offset = (upperbound - lowerbound) * stride;
1633       total_offset += offset;
1634       tmp_type = TYPE_TARGET_TYPE (tmp_type);
1635     }
1636
1637   /* Adjust the address of this object and return it.  */
1638   address += total_offset;
1639   return address;
1640 }
This page took 0.119218 seconds and 4 git commands to generate.