1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897 |
- /* Fortran language support routines for GDB, the GNU debugger.
- Copyright (C) 1993-2022 Free Software Foundation, Inc.
- Contributed by Motorola. Adapted from the C parser by Farooq Butt
- (fmbutt@engage.sps.mot.com).
- This file is part of GDB.
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT 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
- along with this program. If not, see <http://www.gnu.org/licenses/>. */
- #include "defs.h"
- #include "symtab.h"
- #include "gdbtypes.h"
- #include "expression.h"
- #include "parser-defs.h"
- #include "language.h"
- #include "varobj.h"
- #include "gdbcore.h"
- #include "f-lang.h"
- #include "valprint.h"
- #include "value.h"
- #include "cp-support.h"
- #include "charset.h"
- #include "c-lang.h"
- #include "target-float.h"
- #include "gdbarch.h"
- #include "gdbcmd.h"
- #include "f-array-walker.h"
- #include "f-exp.h"
- #include <math.h>
- /* Whether GDB should repack array slices created by the user. */
- static bool repack_array_slices = false;
- /* Implement 'show fortran repack-array-slices'. */
- static void
- show_repack_array_slices (struct ui_file *file, int from_tty,
- struct cmd_list_element *c, const char *value)
- {
- gdb_printf (file, _("Repacking of Fortran array slices is %s.\n"),
- value);
- }
- /* Debugging of Fortran's array slicing. */
- static bool fortran_array_slicing_debug = false;
- /* Implement 'show debug fortran-array-slicing'. */
- static void
- show_fortran_array_slicing_debug (struct ui_file *file, int from_tty,
- struct cmd_list_element *c,
- const char *value)
- {
- gdb_printf (file, _("Debugging of Fortran array slicing is %s.\n"),
- value);
- }
- /* Local functions */
- static value *fortran_prepare_argument (struct expression *exp,
- expr::operation *subexp,
- int arg_num, bool is_internal_call_p,
- struct type *func_type, enum noside noside);
- /* Return the encoding that should be used for the character type
- TYPE. */
- const char *
- f_language::get_encoding (struct type *type)
- {
- const char *encoding;
- switch (TYPE_LENGTH (type))
- {
- case 1:
- encoding = target_charset (type->arch ());
- break;
- case 4:
- if (type_byte_order (type) == BFD_ENDIAN_BIG)
- encoding = "UTF-32BE";
- else
- encoding = "UTF-32LE";
- break;
- default:
- error (_("unrecognized character type"));
- }
- return encoding;
- }
- /* A helper function for the "bound" intrinsics that checks that TYPE
- is an array. LBOUND_P is true for lower bound; this is used for
- the error message, if any. */
- static void
- fortran_require_array (struct type *type, bool lbound_p)
- {
- type = check_typedef (type);
- if (type->code () != TYPE_CODE_ARRAY)
- {
- if (lbound_p)
- error (_("LBOUND can only be applied to arrays"));
- else
- error (_("UBOUND can only be applied to arrays"));
- }
- }
- /* Create an array containing the lower bounds (when LBOUND_P is true) or
- the upper bounds (when LBOUND_P is false) of ARRAY (which must be of
- array type). GDBARCH is the current architecture. */
- static struct value *
- fortran_bounds_all_dims (bool lbound_p,
- struct gdbarch *gdbarch,
- struct value *array)
- {
- type *array_type = check_typedef (value_type (array));
- int ndimensions = calc_f77_array_dims (array_type);
- /* Allocate a result value of the correct type. */
- struct type *range
- = create_static_range_type (nullptr,
- builtin_type (gdbarch)->builtin_int,
- 1, ndimensions);
- struct type *elm_type = builtin_type (gdbarch)->builtin_long_long;
- struct type *result_type = create_array_type (nullptr, elm_type, range);
- struct value *result = allocate_value (result_type);
- /* Walk the array dimensions backwards due to the way the array will be
- laid out in memory, the first dimension will be the most inner. */
- LONGEST elm_len = TYPE_LENGTH (elm_type);
- for (LONGEST dst_offset = elm_len * (ndimensions - 1);
- dst_offset >= 0;
- dst_offset -= elm_len)
- {
- LONGEST b;
- /* Grab the required bound. */
- if (lbound_p)
- b = f77_get_lowerbound (array_type);
- else
- b = f77_get_upperbound (array_type);
- /* And copy the value into the result value. */
- struct value *v = value_from_longest (elm_type, b);
- gdb_assert (dst_offset + TYPE_LENGTH (value_type (v))
- <= TYPE_LENGTH (value_type (result)));
- gdb_assert (TYPE_LENGTH (value_type (v)) == elm_len);
- value_contents_copy (result, dst_offset, v, 0, elm_len);
- /* Peel another dimension of the array. */
- array_type = TYPE_TARGET_TYPE (array_type);
- }
- return result;
- }
- /* Return the lower bound (when LBOUND_P is true) or the upper bound (when
- LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
- ARRAY (which must be an array). GDBARCH is the current architecture. */
- static struct value *
- fortran_bounds_for_dimension (bool lbound_p,
- struct gdbarch *gdbarch,
- struct value *array,
- struct value *dim_val)
- {
- /* Check the requested dimension is valid for this array. */
- type *array_type = check_typedef (value_type (array));
- int ndimensions = calc_f77_array_dims (array_type);
- long dim = value_as_long (dim_val);
- if (dim < 1 || dim > ndimensions)
- {
- if (lbound_p)
- error (_("LBOUND dimension must be from 1 to %d"), ndimensions);
- else
- error (_("UBOUND dimension must be from 1 to %d"), ndimensions);
- }
- /* The type for the result. */
- struct type *bound_type = builtin_type (gdbarch)->builtin_long_long;
- /* Walk the dimensions backwards, due to the ordering in which arrays are
- laid out the first dimension is the most inner. */
- for (int i = ndimensions - 1; i >= 0; --i)
- {
- /* If this is the requested dimension then we're done. Grab the
- bounds and return. */
- if (i == dim - 1)
- {
- LONGEST b;
- if (lbound_p)
- b = f77_get_lowerbound (array_type);
- else
- b = f77_get_upperbound (array_type);
- return value_from_longest (bound_type, b);
- }
- /* Peel off another dimension of the array. */
- array_type = TYPE_TARGET_TYPE (array_type);
- }
- gdb_assert_not_reached ("failed to find matching dimension");
- }
- /* Return the number of dimensions for a Fortran array or string. */
- int
- calc_f77_array_dims (struct type *array_type)
- {
- int ndimen = 1;
- struct type *tmp_type;
- if ((array_type->code () == TYPE_CODE_STRING))
- return 1;
- if ((array_type->code () != TYPE_CODE_ARRAY))
- error (_("Can't get dimensions for a non-array type"));
- tmp_type = array_type;
- while ((tmp_type = TYPE_TARGET_TYPE (tmp_type)))
- {
- if (tmp_type->code () == TYPE_CODE_ARRAY)
- ++ndimen;
- }
- return ndimen;
- }
- /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
- slices. This is a base class for two alternative repacking mechanisms,
- one for when repacking from a lazy value, and one for repacking from a
- non-lazy (already loaded) value. */
- class fortran_array_repacker_base_impl
- : public fortran_array_walker_base_impl
- {
- public:
- /* Constructor, DEST is the value we are repacking into. */
- fortran_array_repacker_base_impl (struct value *dest)
- : m_dest (dest),
- m_dest_offset (0)
- { /* Nothing. */ }
- /* When we start processing the inner most dimension, this is where we
- will be creating values for each element as we load them and then copy
- them into the M_DEST value. Set a value mark so we can free these
- temporary values. */
- void start_dimension (struct type *index_type, LONGEST nelts, bool inner_p)
- {
- if (inner_p)
- {
- gdb_assert (m_mark == nullptr);
- m_mark = value_mark ();
- }
- }
- /* When we finish processing the inner most dimension free all temporary
- value that were created. */
- void finish_dimension (bool inner_p, bool last_p)
- {
- if (inner_p)
- {
- gdb_assert (m_mark != nullptr);
- value_free_to_mark (m_mark);
- m_mark = nullptr;
- }
- }
- protected:
- /* Copy the contents of array element ELT into M_DEST at the next
- available offset. */
- void copy_element_to_dest (struct value *elt)
- {
- value_contents_copy (m_dest, m_dest_offset, elt, 0,
- TYPE_LENGTH (value_type (elt)));
- m_dest_offset += TYPE_LENGTH (value_type (elt));
- }
- /* The value being written to. */
- struct value *m_dest;
- /* The byte offset in M_DEST at which the next element should be
- written. */
- LONGEST m_dest_offset;
- /* Set with a call to VALUE_MARK, and then reset after calling
- VALUE_FREE_TO_MARK. */
- struct value *m_mark = nullptr;
- };
- /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
- slices. This class is specialised for repacking an array slice from a
- lazy array value, as such it does not require the parent array value to
- be loaded into GDB's memory; the parent value could be huge, while the
- slice could be tiny. */
- class fortran_lazy_array_repacker_impl
- : public fortran_array_repacker_base_impl
- {
- public:
- /* Constructor. TYPE is the type of the slice being loaded from the
- parent value, so this type will correctly reflect the strides required
- to find all of the elements from the parent value. ADDRESS is the
- address in target memory of value matching TYPE, and DEST is the value
- we are repacking into. */
- explicit fortran_lazy_array_repacker_impl (struct type *type,
- CORE_ADDR address,
- struct value *dest)
- : fortran_array_repacker_base_impl (dest),
- m_addr (address)
- { /* Nothing. */ }
- /* Create a lazy value in target memory representing a single element,
- then load the element into GDB's memory and copy the contents into the
- destination value. */
- void process_element (struct type *elt_type, LONGEST elt_off,
- LONGEST index, bool last_p)
- {
- copy_element_to_dest (value_at_lazy (elt_type, m_addr + elt_off));
- }
- private:
- /* The address in target memory where the parent value starts. */
- CORE_ADDR m_addr;
- };
- /* A class used by FORTRAN_VALUE_SUBARRAY when repacking Fortran array
- slices. This class is specialised for repacking an array slice from a
- previously loaded (non-lazy) array value, as such it fetches the
- element values from the contents of the parent value. */
- class fortran_array_repacker_impl
- : public fortran_array_repacker_base_impl
- {
- public:
- /* Constructor. TYPE is the type for the array slice within the parent
- value, as such it has stride values as required to find the elements
- within the original parent value. ADDRESS is the address in target
- memory of the value matching TYPE. BASE_OFFSET is the offset from
- the start of VAL's content buffer to the start of the object of TYPE,
- VAL is the parent object from which we are loading the value, and
- DEST is the value into which we are repacking. */
- explicit fortran_array_repacker_impl (struct type *type, CORE_ADDR address,
- LONGEST base_offset,
- struct value *val, struct value *dest)
- : fortran_array_repacker_base_impl (dest),
- m_base_offset (base_offset),
- m_val (val)
- {
- gdb_assert (!value_lazy (val));
- }
- /* Extract an element of ELT_TYPE at offset (M_BASE_OFFSET + ELT_OFF)
- from the content buffer of M_VAL then copy this extracted value into
- the repacked destination value. */
- void process_element (struct type *elt_type, LONGEST elt_off,
- LONGEST index, bool last_p)
- {
- struct value *elt
- = value_from_component (m_val, elt_type, (elt_off + m_base_offset));
- copy_element_to_dest (elt);
- }
- private:
- /* The offset into the content buffer of M_VAL to the start of the slice
- being extracted. */
- LONGEST m_base_offset;
- /* The parent value from which we are extracting a slice. */
- struct value *m_val;
- };
- /* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are
- extracted from the expression being evaluated. POINTER is the required
- first argument to the 'associated' keyword, and TARGET is the optional
- second argument, this will be nullptr if the user only passed one
- argument to their use of 'associated'. */
- static struct value *
- fortran_associated (struct gdbarch *gdbarch, const language_defn *lang,
- struct value *pointer, struct value *target = nullptr)
- {
- struct type *result_type = language_bool_type (lang, gdbarch);
- /* All Fortran pointers should have the associated property, this is
- how we know the pointer is pointing at something or not. */
- struct type *pointer_type = check_typedef (value_type (pointer));
- if (TYPE_ASSOCIATED_PROP (pointer_type) == nullptr
- && pointer_type->code () != TYPE_CODE_PTR)
- error (_("ASSOCIATED can only be applied to pointers"));
- /* Get an address from POINTER. Fortran (or at least gfortran) models
- array pointers as arrays with a dynamic data address, so we need to
- use two approaches here, for real pointers we take the contents of the
- pointer as an address. For non-pointers we take the address of the
- content. */
- CORE_ADDR pointer_addr;
- if (pointer_type->code () == TYPE_CODE_PTR)
- pointer_addr = value_as_address (pointer);
- else
- pointer_addr = value_address (pointer);
- /* The single argument case, is POINTER associated with anything? */
- if (target == nullptr)
- {
- bool is_associated = false;
- /* If POINTER is an actual pointer and doesn't have an associated
- property then we need to figure out whether this pointer is
- associated by looking at the value of the pointer itself. We make
- the assumption that a non-associated pointer will be set to 0.
- This is probably true for most targets, but might not be true for
- everyone. */
- if (pointer_type->code () == TYPE_CODE_PTR
- && TYPE_ASSOCIATED_PROP (pointer_type) == nullptr)
- is_associated = (pointer_addr != 0);
- else
- is_associated = !type_not_associated (pointer_type);
- return value_from_longest (result_type, is_associated ? 1 : 0);
- }
- /* The two argument case, is POINTER associated with TARGET? */
- struct type *target_type = check_typedef (value_type (target));
- struct type *pointer_target_type;
- if (pointer_type->code () == TYPE_CODE_PTR)
- pointer_target_type = TYPE_TARGET_TYPE (pointer_type);
- else
- pointer_target_type = pointer_type;
- struct type *target_target_type;
- if (target_type->code () == TYPE_CODE_PTR)
- target_target_type = TYPE_TARGET_TYPE (target_type);
- else
- target_target_type = target_type;
- if (pointer_target_type->code () != target_target_type->code ()
- || (pointer_target_type->code () != TYPE_CODE_ARRAY
- && (TYPE_LENGTH (pointer_target_type)
- != TYPE_LENGTH (target_target_type))))
- error (_("arguments to associated must be of same type and kind"));
- /* If TARGET is not in memory, or the original pointer is specifically
- known to be not associated with anything, then the answer is obviously
- false. Alternatively, if POINTER is an actual pointer and has no
- associated property, then we have to check if its associated by
- looking the value of the pointer itself. We make the assumption that
- a non-associated pointer will be set to 0. This is probably true for
- most targets, but might not be true for everyone. */
- if (value_lval_const (target) != lval_memory
- || type_not_associated (pointer_type)
- || (TYPE_ASSOCIATED_PROP (pointer_type) == nullptr
- && pointer_type->code () == TYPE_CODE_PTR
- && pointer_addr == 0))
- return value_from_longest (result_type, 0);
- /* See the comment for POINTER_ADDR above. */
- CORE_ADDR target_addr;
- if (target_type->code () == TYPE_CODE_PTR)
- target_addr = value_as_address (target);
- else
- target_addr = value_address (target);
- /* Wrap the following checks inside a do { ... } while (false) loop so
- that we can use `break' to jump out of the loop. */
- bool is_associated = false;
- do
- {
- /* If the addresses are different then POINTER is definitely not
- pointing at TARGET. */
- if (pointer_addr != target_addr)
- break;
- /* If POINTER is a real pointer (i.e. not an array pointer, which are
- implemented as arrays with a dynamic content address), then this
- is all the checking that is needed. */
- if (pointer_type->code () == TYPE_CODE_PTR)
- {
- is_associated = true;
- break;
- }
- /* We have an array pointer. Check the number of dimensions. */
- int pointer_dims = calc_f77_array_dims (pointer_type);
- int target_dims = calc_f77_array_dims (target_type);
- if (pointer_dims != target_dims)
- break;
- /* Now check that every dimension has the same upper bound, lower
- bound, and stride value. */
- int dim = 0;
- while (dim < pointer_dims)
- {
- LONGEST pointer_lowerbound, pointer_upperbound, pointer_stride;
- LONGEST target_lowerbound, target_upperbound, target_stride;
- pointer_type = check_typedef (pointer_type);
- target_type = check_typedef (target_type);
- struct type *pointer_range = pointer_type->index_type ();
- struct type *target_range = target_type->index_type ();
- if (!get_discrete_bounds (pointer_range, &pointer_lowerbound,
- &pointer_upperbound))
- break;
- if (!get_discrete_bounds (target_range, &target_lowerbound,
- &target_upperbound))
- break;
- if (pointer_lowerbound != target_lowerbound
- || pointer_upperbound != target_upperbound)
- break;
- /* Figure out the stride (in bits) for both pointer and target.
- If either doesn't have a stride then we take the element size,
- but we need to convert to bits (hence the * 8). */
- pointer_stride = pointer_range->bounds ()->bit_stride ();
- if (pointer_stride == 0)
- pointer_stride
- = type_length_units (check_typedef
- (TYPE_TARGET_TYPE (pointer_type))) * 8;
- target_stride = target_range->bounds ()->bit_stride ();
- if (target_stride == 0)
- target_stride
- = type_length_units (check_typedef
- (TYPE_TARGET_TYPE (target_type))) * 8;
- if (pointer_stride != target_stride)
- break;
- ++dim;
- }
- if (dim < pointer_dims)
- break;
- is_associated = true;
- }
- while (false);
- return value_from_longest (result_type, is_associated ? 1 : 0);
- }
- struct value *
- eval_op_f_associated (struct type *expect_type,
- struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1)
- {
- return fortran_associated (exp->gdbarch, exp->language_defn, arg1);
- }
- struct value *
- eval_op_f_associated (struct type *expect_type,
- struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1,
- struct value *arg2)
- {
- return fortran_associated (exp->gdbarch, exp->language_defn, arg1, arg2);
- }
- /* Implement FORTRAN_ARRAY_SIZE expression, this corresponds to the 'SIZE'
- keyword. Both GDBARCH and LANG are extracted from the expression being
- evaluated. ARRAY is the value that should be an array, though this will
- not have been checked before calling this function. DIM is optional, if
- present then it should be an integer identifying a dimension of the
- array to ask about. As with ARRAY the validity of DIM is not checked
- before calling this function.
- Return either the total number of elements in ARRAY (when DIM is
- nullptr), or the number of elements in dimension DIM. */
- static struct value *
- fortran_array_size (struct gdbarch *gdbarch, const language_defn *lang,
- struct value *array, struct value *dim_val = nullptr)
- {
- /* Check that ARRAY is the correct type. */
- struct type *array_type = check_typedef (value_type (array));
- if (array_type->code () != TYPE_CODE_ARRAY)
- error (_("SIZE can only be applied to arrays"));
- if (type_not_allocated (array_type) || type_not_associated (array_type))
- error (_("SIZE can only be used on allocated/associated arrays"));
- int ndimensions = calc_f77_array_dims (array_type);
- int dim = -1;
- LONGEST result = 0;
- if (dim_val != nullptr)
- {
- if (check_typedef (value_type (dim_val))->code () != TYPE_CODE_INT)
- error (_("DIM argument to SIZE must be an integer"));
- dim = (int) value_as_long (dim_val);
- if (dim < 1 || dim > ndimensions)
- error (_("DIM argument to SIZE must be between 1 and %d"),
- ndimensions);
- }
- /* Now walk over all the dimensions of the array totalling up the
- elements in each dimension. */
- for (int i = ndimensions - 1; i >= 0; --i)
- {
- /* If this is the requested dimension then we're done. Grab the
- bounds and return. */
- if (i == dim - 1 || dim == -1)
- {
- LONGEST lbound, ubound;
- struct type *range = array_type->index_type ();
- if (!get_discrete_bounds (range, &lbound, &ubound))
- error (_("failed to find array bounds"));
- LONGEST dim_size = (ubound - lbound + 1);
- if (result == 0)
- result = dim_size;
- else
- result *= dim_size;
- if (dim != -1)
- break;
- }
- /* Peel off another dimension of the array. */
- array_type = TYPE_TARGET_TYPE (array_type);
- }
- struct type *result_type
- = builtin_f_type (gdbarch)->builtin_integer;
- return value_from_longest (result_type, result);
- }
- /* See f-exp.h. */
- struct value *
- eval_op_f_array_size (struct type *expect_type,
- struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1)
- {
- gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
- return fortran_array_size (exp->gdbarch, exp->language_defn, arg1);
- }
- /* See f-exp.h. */
- struct value *
- eval_op_f_array_size (struct type *expect_type,
- struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1,
- struct value *arg2)
- {
- gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
- return fortran_array_size (exp->gdbarch, exp->language_defn, arg1, arg2);
- }
- /* Implement UNOP_FORTRAN_SHAPE expression. Both GDBARCH and LANG are
- extracted from the expression being evaluated. VAL is the value on
- which 'shape' was used, this can be any type.
- Return an array of integers. If VAL is not an array then the returned
- array should have zero elements. If VAL is an array then the returned
- array should have one element per dimension, with the element
- containing the extent of that dimension from VAL. */
- static struct value *
- fortran_array_shape (struct gdbarch *gdbarch, const language_defn *lang,
- struct value *val)
- {
- struct type *val_type = check_typedef (value_type (val));
- /* If we are passed an array that is either not allocated, or not
- associated, then this is explicitly not allowed according to the
- Fortran specification. */
- if (val_type->code () == TYPE_CODE_ARRAY
- && (type_not_associated (val_type) || type_not_allocated (val_type)))
- error (_("The array passed to SHAPE must be allocated or associated"));
- /* The Fortran specification allows non-array types to be passed to this
- function, in which case we get back an empty array.
- Calculate the number of dimensions for the resulting array. */
- int ndimensions = 0;
- if (val_type->code () == TYPE_CODE_ARRAY)
- ndimensions = calc_f77_array_dims (val_type);
- /* Allocate a result value of the correct type. */
- struct type *range
- = create_static_range_type (nullptr,
- builtin_type (gdbarch)->builtin_int,
- 1, ndimensions);
- struct type *elm_type = builtin_f_type (gdbarch)->builtin_integer;
- struct type *result_type = create_array_type (nullptr, elm_type, range);
- struct value *result = allocate_value (result_type);
- LONGEST elm_len = TYPE_LENGTH (elm_type);
- /* Walk the array dimensions backwards due to the way the array will be
- laid out in memory, the first dimension will be the most inner.
- If VAL was not an array then ndimensions will be 0, in which case we
- will never go around this loop. */
- for (LONGEST dst_offset = elm_len * (ndimensions - 1);
- dst_offset >= 0;
- dst_offset -= elm_len)
- {
- LONGEST lbound, ubound;
- if (!get_discrete_bounds (val_type->index_type (), &lbound, &ubound))
- error (_("failed to find array bounds"));
- LONGEST dim_size = (ubound - lbound + 1);
- /* And copy the value into the result value. */
- struct value *v = value_from_longest (elm_type, dim_size);
- gdb_assert (dst_offset + TYPE_LENGTH (value_type (v))
- <= TYPE_LENGTH (value_type (result)));
- gdb_assert (TYPE_LENGTH (value_type (v)) == elm_len);
- value_contents_copy (result, dst_offset, v, 0, elm_len);
- /* Peel another dimension of the array. */
- val_type = TYPE_TARGET_TYPE (val_type);
- }
- return result;
- }
- /* See f-exp.h. */
- struct value *
- eval_op_f_array_shape (struct type *expect_type, struct expression *exp,
- enum noside noside, enum exp_opcode opcode,
- struct value *arg1)
- {
- gdb_assert (opcode == UNOP_FORTRAN_SHAPE);
- return fortran_array_shape (exp->gdbarch, exp->language_defn, arg1);
- }
- /* A helper function for UNOP_ABS. */
- struct value *
- eval_op_f_abs (struct type *expect_type, struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1)
- {
- struct type *type = value_type (arg1);
- switch (type->code ())
- {
- case TYPE_CODE_FLT:
- {
- double d
- = fabs (target_float_to_host_double (value_contents (arg1).data (),
- value_type (arg1)));
- return value_from_host_double (type, d);
- }
- case TYPE_CODE_INT:
- {
- LONGEST l = value_as_long (arg1);
- l = llabs (l);
- return value_from_longest (type, l);
- }
- }
- error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type));
- }
- /* A helper function for BINOP_MOD. */
- struct value *
- eval_op_f_mod (struct type *expect_type, struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1, struct value *arg2)
- {
- struct type *type = value_type (arg1);
- if (type->code () != value_type (arg2)->code ())
- error (_("non-matching types for parameters to MOD ()"));
- switch (type->code ())
- {
- case TYPE_CODE_FLT:
- {
- double d1
- = target_float_to_host_double (value_contents (arg1).data (),
- value_type (arg1));
- double d2
- = target_float_to_host_double (value_contents (arg2).data (),
- value_type (arg2));
- double d3 = fmod (d1, d2);
- return value_from_host_double (type, d3);
- }
- case TYPE_CODE_INT:
- {
- LONGEST v1 = value_as_long (arg1);
- LONGEST v2 = value_as_long (arg2);
- if (v2 == 0)
- error (_("calling MOD (N, 0) is undefined"));
- LONGEST v3 = v1 - (v1 / v2) * v2;
- return value_from_longest (value_type (arg1), v3);
- }
- }
- error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
- }
- /* A helper function for UNOP_FORTRAN_CEILING. */
- struct value *
- eval_op_f_ceil (struct type *expect_type, struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1)
- {
- struct type *type = value_type (arg1);
- if (type->code () != TYPE_CODE_FLT)
- error (_("argument to CEILING must be of type float"));
- double val
- = target_float_to_host_double (value_contents (arg1).data (),
- value_type (arg1));
- val = ceil (val);
- return value_from_host_double (type, val);
- }
- /* A helper function for UNOP_FORTRAN_FLOOR. */
- struct value *
- eval_op_f_floor (struct type *expect_type, struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1)
- {
- struct type *type = value_type (arg1);
- if (type->code () != TYPE_CODE_FLT)
- error (_("argument to FLOOR must be of type float"));
- double val
- = target_float_to_host_double (value_contents (arg1).data (),
- value_type (arg1));
- val = floor (val);
- return value_from_host_double (type, val);
- }
- /* A helper function for BINOP_FORTRAN_MODULO. */
- struct value *
- eval_op_f_modulo (struct type *expect_type, struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1, struct value *arg2)
- {
- struct type *type = value_type (arg1);
- if (type->code () != value_type (arg2)->code ())
- error (_("non-matching types for parameters to MODULO ()"));
- /* MODULO(A, P) = A - FLOOR (A / P) * P */
- switch (type->code ())
- {
- case TYPE_CODE_INT:
- {
- LONGEST a = value_as_long (arg1);
- LONGEST p = value_as_long (arg2);
- LONGEST result = a - (a / p) * p;
- if (result != 0 && (a < 0) != (p < 0))
- result += p;
- return value_from_longest (value_type (arg1), result);
- }
- case TYPE_CODE_FLT:
- {
- double a
- = target_float_to_host_double (value_contents (arg1).data (),
- value_type (arg1));
- double p
- = target_float_to_host_double (value_contents (arg2).data (),
- value_type (arg2));
- double result = fmod (a, p);
- if (result != 0 && (a < 0.0) != (p < 0.0))
- result += p;
- return value_from_host_double (type, result);
- }
- }
- error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
- }
- /* A helper function for BINOP_FORTRAN_CMPLX. */
- struct value *
- eval_op_f_cmplx (struct type *expect_type, struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1, struct value *arg2)
- {
- struct type *type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
- return value_literal_complex (arg1, arg2, type);
- }
- /* A helper function for UNOP_FORTRAN_KIND. */
- struct value *
- eval_op_f_kind (struct type *expect_type, struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1)
- {
- struct type *type = value_type (arg1);
- switch (type->code ())
- {
- case TYPE_CODE_STRUCT:
- case TYPE_CODE_UNION:
- case TYPE_CODE_MODULE:
- case TYPE_CODE_FUNC:
- error (_("argument to kind must be an intrinsic type"));
- }
- if (!TYPE_TARGET_TYPE (type))
- return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
- TYPE_LENGTH (type));
- return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
- TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
- }
- /* A helper function for UNOP_FORTRAN_ALLOCATED. */
- struct value *
- eval_op_f_allocated (struct type *expect_type, struct expression *exp,
- enum noside noside, enum exp_opcode op,
- struct value *arg1)
- {
- struct type *type = check_typedef (value_type (arg1));
- if (type->code () != TYPE_CODE_ARRAY)
- error (_("ALLOCATED can only be applied to arrays"));
- struct type *result_type
- = builtin_f_type (exp->gdbarch)->builtin_logical;
- LONGEST result_value = type_not_allocated (type) ? 0 : 1;
- return value_from_longest (result_type, result_value);
- }
- /* See f-exp.h. */
- struct value *
- eval_op_f_rank (struct type *expect_type,
- struct expression *exp,
- enum noside noside,
- enum exp_opcode op,
- struct value *arg1)
- {
- gdb_assert (op == UNOP_FORTRAN_RANK);
- struct type *result_type
- = builtin_f_type (exp->gdbarch)->builtin_integer;
- struct type *type = check_typedef (value_type (arg1));
- if (type->code () != TYPE_CODE_ARRAY)
- return value_from_longest (result_type, 0);
- LONGEST ndim = calc_f77_array_dims (type);
- return value_from_longest (result_type, ndim);
- }
- /* A helper function for UNOP_FORTRAN_LOC. */
- struct value *
- eval_op_f_loc (struct type *expect_type, struct expression *exp,
- enum noside noside, enum exp_opcode op,
- struct value *arg1)
- {
- struct type *result_type;
- if (gdbarch_ptr_bit (exp->gdbarch) == 16)
- result_type = builtin_f_type (exp->gdbarch)->builtin_integer_s2;
- else if (gdbarch_ptr_bit (exp->gdbarch) == 32)
- result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
- else
- result_type = builtin_f_type (exp->gdbarch)->builtin_integer_s8;
- LONGEST result_value = value_address (arg1);
- return value_from_longest (result_type, result_value);
- }
- namespace expr
- {
- /* Called from evaluate to perform array indexing, and sub-range
- extraction, for Fortran. As well as arrays this function also
- handles strings as they can be treated like arrays of characters.
- ARRAY is the array or string being accessed. EXP and NOSIDE are as
- for evaluate. */
- value *
- fortran_undetermined::value_subarray (value *array,
- struct expression *exp,
- enum noside noside)
- {
- type *original_array_type = check_typedef (value_type (array));
- bool is_string_p = original_array_type->code () == TYPE_CODE_STRING;
- const std::vector<operation_up> &ops = std::get<1> (m_storage);
- int nargs = ops.size ();
- /* Perform checks for ARRAY not being available. The somewhat overly
- complex logic here is just to keep backward compatibility with the
- errors that we used to get before FORTRAN_VALUE_SUBARRAY was
- rewritten. Maybe a future task would streamline the error messages we
- get here, and update all the expected test results. */
- if (ops[0]->opcode () != OP_RANGE)
- {
- if (type_not_associated (original_array_type))
- error (_("no such vector element (vector not associated)"));
- else if (type_not_allocated (original_array_type))
- error (_("no such vector element (vector not allocated)"));
- }
- else
- {
- if (type_not_associated (original_array_type))
- error (_("array not associated"));
- else if (type_not_allocated (original_array_type))
- error (_("array not allocated"));
- }
- /* First check that the number of dimensions in the type we are slicing
- matches the number of arguments we were passed. */
- int ndimensions = calc_f77_array_dims (original_array_type);
- if (nargs != ndimensions)
- error (_("Wrong number of subscripts"));
- /* This will be initialised below with the type of the elements held in
- ARRAY. */
- struct type *inner_element_type;
- /* Extract the types of each array dimension from the original array
- type. We need these available so we can fill in the default upper and
- lower bounds if the user requested slice doesn't provide that
- information. Additionally unpacking the dimensions like this gives us
- the inner element type. */
- std::vector<struct type *> dim_types;
- {
- dim_types.reserve (ndimensions);
- struct type *type = original_array_type;
- for (int i = 0; i < ndimensions; ++i)
- {
- dim_types.push_back (type);
- type = TYPE_TARGET_TYPE (type);
- }
- /* TYPE is now the inner element type of the array, we start the new
- array slice off as this type, then as we process the requested slice
- (from the user) we wrap new types around this to build up the final
- slice type. */
- inner_element_type = type;
- }
- /* As we analyse the new slice type we need to understand if the data
- being referenced is contiguous. Do decide this we must track the size
- of an element at each dimension of the new slice array. Initially the
- elements of the inner most dimension of the array are the same inner
- most elements as the original ARRAY. */
- LONGEST slice_element_size = TYPE_LENGTH (inner_element_type);
- /* Start off assuming all data is contiguous, this will be set to false
- if access to any dimension results in non-contiguous data. */
- bool is_all_contiguous = true;
- /* The TOTAL_OFFSET is the distance in bytes from the start of the
- original ARRAY to the start of the new slice. This is calculated as
- we process the information from the user. */
- LONGEST total_offset = 0;
- /* A structure representing information about each dimension of the
- resulting slice. */
- struct slice_dim
- {
- /* Constructor. */
- slice_dim (LONGEST l, LONGEST h, LONGEST s, struct type *idx)
- : low (l),
- high (h),
- stride (s),
- index (idx)
- { /* Nothing. */ }
- /* The low bound for this dimension of the slice. */
- LONGEST low;
- /* The high bound for this dimension of the slice. */
- LONGEST high;
- /* The byte stride for this dimension of the slice. */
- LONGEST stride;
- struct type *index;
- };
- /* The dimensions of the resulting slice. */
- std::vector<slice_dim> slice_dims;
- /* Process the incoming arguments. These arguments are in the reverse
- order to the array dimensions, that is the first argument refers to
- the last array dimension. */
- if (fortran_array_slicing_debug)
- debug_printf ("Processing array access:\n");
- for (int i = 0; i < nargs; ++i)
- {
- /* For each dimension of the array the user will have either provided
- a ranged access with optional lower bound, upper bound, and
- stride, or the user will have supplied a single index. */
- struct type *dim_type = dim_types[ndimensions - (i + 1)];
- fortran_range_operation *range_op
- = dynamic_cast<fortran_range_operation *> (ops[i].get ());
- if (range_op != nullptr)
- {
- enum range_flag range_flag = range_op->get_flags ();
- LONGEST low, high, stride;
- low = high = stride = 0;
- if ((range_flag & RANGE_LOW_BOUND_DEFAULT) == 0)
- low = value_as_long (range_op->evaluate0 (exp, noside));
- else
- low = f77_get_lowerbound (dim_type);
- if ((range_flag & RANGE_HIGH_BOUND_DEFAULT) == 0)
- high = value_as_long (range_op->evaluate1 (exp, noside));
- else
- high = f77_get_upperbound (dim_type);
- if ((range_flag & RANGE_HAS_STRIDE) == RANGE_HAS_STRIDE)
- stride = value_as_long (range_op->evaluate2 (exp, noside));
- else
- stride = 1;
- if (stride == 0)
- error (_("stride must not be 0"));
- /* Get information about this dimension in the original ARRAY. */
- struct type *target_type = TYPE_TARGET_TYPE (dim_type);
- struct type *index_type = dim_type->index_type ();
- LONGEST lb = f77_get_lowerbound (dim_type);
- LONGEST ub = f77_get_upperbound (dim_type);
- LONGEST sd = index_type->bit_stride ();
- if (sd == 0)
- sd = TYPE_LENGTH (target_type) * 8;
- if (fortran_array_slicing_debug)
- {
- debug_printf ("|-> Range access\n");
- std::string str = type_to_string (dim_type);
- debug_printf ("| |-> Type: %s\n", str.c_str ());
- debug_printf ("| |-> Array:\n");
- debug_printf ("| | |-> Low bound: %s\n", plongest (lb));
- debug_printf ("| | |-> High bound: %s\n", plongest (ub));
- debug_printf ("| | |-> Bit stride: %s\n", plongest (sd));
- debug_printf ("| | |-> Byte stride: %s\n", plongest (sd / 8));
- debug_printf ("| | |-> Type size: %s\n",
- pulongest (TYPE_LENGTH (dim_type)));
- debug_printf ("| | '-> Target type size: %s\n",
- pulongest (TYPE_LENGTH (target_type)));
- debug_printf ("| |-> Accessing:\n");
- debug_printf ("| | |-> Low bound: %s\n",
- plongest (low));
- debug_printf ("| | |-> High bound: %s\n",
- plongest (high));
- debug_printf ("| | '-> Element stride: %s\n",
- plongest (stride));
- }
- /* Check the user hasn't asked for something invalid. */
- if (high > ub || low < lb)
- error (_("array subscript out of bounds"));
- /* Calculate what this dimension of the new slice array will look
- like. OFFSET is the byte offset from the start of the
- previous (more outer) dimension to the start of this
- dimension. E_COUNT is the number of elements in this
- dimension. REMAINDER is the number of elements remaining
- between the last included element and the upper bound. For
- example an access '1:6:2' will include elements 1, 3, 5 and
- have a remainder of 1 (element #6). */
- LONGEST lowest = std::min (low, high);
- LONGEST offset = (sd / 8) * (lowest - lb);
- LONGEST e_count = std::abs (high - low) + 1;
- e_count = (e_count + (std::abs (stride) - 1)) / std::abs (stride);
- LONGEST new_low = 1;
- LONGEST new_high = new_low + e_count - 1;
- LONGEST new_stride = (sd * stride) / 8;
- LONGEST last_elem = low + ((e_count - 1) * stride);
- LONGEST remainder = high - last_elem;
- if (low > high)
- {
- offset += std::abs (remainder) * TYPE_LENGTH (target_type);
- if (stride > 0)
- error (_("incorrect stride and boundary combination"));
- }
- else if (stride < 0)
- error (_("incorrect stride and boundary combination"));
- /* Is the data within this dimension contiguous? It is if the
- newly computed stride is the same size as a single element of
- this dimension. */
- bool is_dim_contiguous = (new_stride == slice_element_size);
- is_all_contiguous &= is_dim_contiguous;
- if (fortran_array_slicing_debug)
- {
- debug_printf ("| '-> Results:\n");
- debug_printf ("| |-> Offset = %s\n", plongest (offset));
- debug_printf ("| |-> Elements = %s\n", plongest (e_count));
- debug_printf ("| |-> Low bound = %s\n", plongest (new_low));
- debug_printf ("| |-> High bound = %s\n",
- plongest (new_high));
- debug_printf ("| |-> Byte stride = %s\n",
- plongest (new_stride));
- debug_printf ("| |-> Last element = %s\n",
- plongest (last_elem));
- debug_printf ("| |-> Remainder = %s\n",
- plongest (remainder));
- debug_printf ("| '-> Contiguous = %s\n",
- (is_dim_contiguous ? "Yes" : "No"));
- }
- /* Figure out how big (in bytes) an element of this dimension of
- the new array slice will be. */
- slice_element_size = std::abs (new_stride * e_count);
- slice_dims.emplace_back (new_low, new_high, new_stride,
- index_type);
- /* Update the total offset. */
- total_offset += offset;
- }
- else
- {
- /* There is a single index for this dimension. */
- LONGEST index
- = value_as_long (ops[i]->evaluate_with_coercion (exp, noside));
- /* Get information about this dimension in the original ARRAY. */
- struct type *target_type = TYPE_TARGET_TYPE (dim_type);
- struct type *index_type = dim_type->index_type ();
- LONGEST lb = f77_get_lowerbound (dim_type);
- LONGEST ub = f77_get_upperbound (dim_type);
- LONGEST sd = index_type->bit_stride () / 8;
- if (sd == 0)
- sd = TYPE_LENGTH (target_type);
- if (fortran_array_slicing_debug)
- {
- debug_printf ("|-> Index access\n");
- std::string str = type_to_string (dim_type);
- debug_printf ("| |-> Type: %s\n", str.c_str ());
- debug_printf ("| |-> Array:\n");
- debug_printf ("| | |-> Low bound: %s\n", plongest (lb));
- debug_printf ("| | |-> High bound: %s\n", plongest (ub));
- debug_printf ("| | |-> Byte stride: %s\n", plongest (sd));
- debug_printf ("| | |-> Type size: %s\n",
- pulongest (TYPE_LENGTH (dim_type)));
- debug_printf ("| | '-> Target type size: %s\n",
- pulongest (TYPE_LENGTH (target_type)));
- debug_printf ("| '-> Accessing:\n");
- debug_printf ("| '-> Index: %s\n",
- plongest (index));
- }
- /* If the array has actual content then check the index is in
- bounds. An array without content (an unbound array) doesn't
- have a known upper bound, so don't error check in that
- situation. */
- if (index < lb
- || (dim_type->index_type ()->bounds ()->high.kind () != PROP_UNDEFINED
- && index > ub)
- || (VALUE_LVAL (array) != lval_memory
- && dim_type->index_type ()->bounds ()->high.kind () == PROP_UNDEFINED))
- {
- if (type_not_associated (dim_type))
- error (_("no such vector element (vector not associated)"));
- else if (type_not_allocated (dim_type))
- error (_("no such vector element (vector not allocated)"));
- else
- error (_("no such vector element"));
- }
- /* Calculate using the type stride, not the target type size. */
- LONGEST offset = sd * (index - lb);
- total_offset += offset;
- }
- }
- /* Build a type that represents the new array slice in the target memory
- of the original ARRAY, this type makes use of strides to correctly
- find only those elements that are part of the new slice. */
- struct type *array_slice_type = inner_element_type;
- for (const auto &d : slice_dims)
- {
- /* Create the range. */
- dynamic_prop p_low, p_high, p_stride;
- p_low.set_const_val (d.low);
- p_high.set_const_val (d.high);
- p_stride.set_const_val (d.stride);
- struct type *new_range
- = create_range_type_with_stride ((struct type *) NULL,
- TYPE_TARGET_TYPE (d.index),
- &p_low, &p_high, 0, &p_stride,
- true);
- array_slice_type
- = create_array_type (nullptr, array_slice_type, new_range);
- }
- if (fortran_array_slicing_debug)
- {
- debug_printf ("'-> Final result:\n");
- debug_printf (" |-> Type: %s\n",
- type_to_string (array_slice_type).c_str ());
- debug_printf (" |-> Total offset: %s\n",
- plongest (total_offset));
- debug_printf (" |-> Base address: %s\n",
- core_addr_to_string (value_address (array)));
- debug_printf (" '-> Contiguous = %s\n",
- (is_all_contiguous ? "Yes" : "No"));
- }
- /* Should we repack this array slice? */
- if (!is_all_contiguous && (repack_array_slices || is_string_p))
- {
- /* Build a type for the repacked slice. */
- struct type *repacked_array_type = inner_element_type;
- for (const auto &d : slice_dims)
- {
- /* Create the range. */
- dynamic_prop p_low, p_high, p_stride;
- p_low.set_const_val (d.low);
- p_high.set_const_val (d.high);
- p_stride.set_const_val (TYPE_LENGTH (repacked_array_type));
- struct type *new_range
- = create_range_type_with_stride ((struct type *) NULL,
- TYPE_TARGET_TYPE (d.index),
- &p_low, &p_high, 0, &p_stride,
- true);
- repacked_array_type
- = create_array_type (nullptr, repacked_array_type, new_range);
- }
- /* Now copy the elements from the original ARRAY into the packed
- array value DEST. */
- struct value *dest = allocate_value (repacked_array_type);
- if (value_lazy (array)
- || (total_offset + TYPE_LENGTH (array_slice_type)
- > TYPE_LENGTH (check_typedef (value_type (array)))))
- {
- fortran_array_walker<fortran_lazy_array_repacker_impl> p
- (array_slice_type, value_address (array) + total_offset, dest);
- p.walk ();
- }
- else
- {
- fortran_array_walker<fortran_array_repacker_impl> p
- (array_slice_type, value_address (array) + total_offset,
- total_offset, array, dest);
- p.walk ();
- }
- array = dest;
- }
- else
- {
- if (VALUE_LVAL (array) == lval_memory)
- {
- /* If the value we're taking a slice from is not yet loaded, or
- the requested slice is outside the values content range then
- just create a new lazy value pointing at the memory where the
- contents we're looking for exist. */
- if (value_lazy (array)
- || (total_offset + TYPE_LENGTH (array_slice_type)
- > TYPE_LENGTH (check_typedef (value_type (array)))))
- array = value_at_lazy (array_slice_type,
- value_address (array) + total_offset);
- else
- array = value_from_contents_and_address
- (array_slice_type, value_contents (array).data () + total_offset,
- value_address (array) + total_offset);
- }
- else if (!value_lazy (array))
- array = value_from_component (array, array_slice_type, total_offset);
- else
- error (_("cannot subscript arrays that are not in memory"));
- }
- return array;
- }
- value *
- fortran_undetermined::evaluate (struct type *expect_type,
- struct expression *exp,
- enum noside noside)
- {
- value *callee = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
- if (noside == EVAL_AVOID_SIDE_EFFECTS
- && is_dynamic_type (value_type (callee)))
- callee = std::get<0> (m_storage)->evaluate (nullptr, exp, EVAL_NORMAL);
- struct type *type = check_typedef (value_type (callee));
- enum type_code code = type->code ();
- if (code == TYPE_CODE_PTR)
- {
- /* Fortran always passes variable to subroutines as pointer.
- So we need to look into its target type to see if it is
- array, string or function. If it is, we need to switch
- to the target value the original one points to. */
- struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
- if (target_type->code () == TYPE_CODE_ARRAY
- || target_type->code () == TYPE_CODE_STRING
- || target_type->code () == TYPE_CODE_FUNC)
- {
- callee = value_ind (callee);
- type = check_typedef (value_type (callee));
- code = type->code ();
- }
- }
- switch (code)
- {
- case TYPE_CODE_ARRAY:
- case TYPE_CODE_STRING:
- return value_subarray (callee, exp, noside);
- case TYPE_CODE_PTR:
- case TYPE_CODE_FUNC:
- case TYPE_CODE_INTERNAL_FUNCTION:
- {
- /* It's a function call. Allocate arg vector, including
- space for the function to be called in argvec[0] and a
- termination NULL. */
- const std::vector<operation_up> &actual (std::get<1> (m_storage));
- std::vector<value *> argvec (actual.size ());
- bool is_internal_func = (code == TYPE_CODE_INTERNAL_FUNCTION);
- for (int tem = 0; tem < argvec.size (); tem++)
- argvec[tem] = fortran_prepare_argument (exp, actual[tem].get (),
- tem, is_internal_func,
- value_type (callee),
- noside);
- return evaluate_subexp_do_call (exp, noside, callee, argvec,
- nullptr, expect_type);
- }
- default:
- error (_("Cannot perform substring on this type"));
- }
- }
- value *
- fortran_bound_1arg::evaluate (struct type *expect_type,
- struct expression *exp,
- enum noside noside)
- {
- bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
- value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
- fortran_require_array (value_type (arg1), lbound_p);
- return fortran_bounds_all_dims (lbound_p, exp->gdbarch, arg1);
- }
- value *
- fortran_bound_2arg::evaluate (struct type *expect_type,
- struct expression *exp,
- enum noside noside)
- {
- bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
- value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
- fortran_require_array (value_type (arg1), lbound_p);
- /* User asked for the bounds of a specific dimension of the array. */
- value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
- struct type *type = check_typedef (value_type (arg2));
- if (type->code () != TYPE_CODE_INT)
- {
- if (lbound_p)
- error (_("LBOUND second argument should be an integer"));
- else
- error (_("UBOUND second argument should be an integer"));
- }
- return fortran_bounds_for_dimension (lbound_p, exp->gdbarch, arg1, arg2);
- }
- /* Implement STRUCTOP_STRUCT for Fortran. See operation::evaluate in
- expression.h for argument descriptions. */
- value *
- fortran_structop_operation::evaluate (struct type *expect_type,
- struct expression *exp,
- enum noside noside)
- {
- value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
- const char *str = std::get<1> (m_storage).c_str ();
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- struct type *type = lookup_struct_elt_type (value_type (arg1), str, 1);
- if (type != nullptr && is_dynamic_type (type))
- arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, EVAL_NORMAL);
- }
- value *elt = value_struct_elt (&arg1, {}, str, NULL, "structure");
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- struct type *elt_type = value_type (elt);
- if (is_dynamic_type (elt_type))
- {
- const gdb_byte *valaddr = value_contents_for_printing (elt).data ();
- CORE_ADDR address = value_address (elt);
- gdb::array_view<const gdb_byte> view
- = gdb::make_array_view (valaddr, TYPE_LENGTH (elt_type));
- elt_type = resolve_dynamic_type (elt_type, view, address);
- }
- elt = value_zero (elt_type, VALUE_LVAL (elt));
- }
- return elt;
- }
- } /* namespace expr */
- /* See language.h. */
- void
- f_language::print_array_index (struct type *index_type, LONGEST index,
- struct ui_file *stream,
- const value_print_options *options) const
- {
- struct value *index_value = value_from_longest (index_type, index);
- gdb_printf (stream, "(");
- value_print (index_value, stream, options);
- gdb_printf (stream, ") = ");
- }
- /* See language.h. */
- void
- f_language::language_arch_info (struct gdbarch *gdbarch,
- struct language_arch_info *lai) const
- {
- const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
- /* Helper function to allow shorter lines below. */
- auto add = [&] (struct type * t)
- {
- lai->add_primitive_type (t);
- };
- add (builtin->builtin_character);
- add (builtin->builtin_logical);
- add (builtin->builtin_logical_s1);
- add (builtin->builtin_logical_s2);
- add (builtin->builtin_logical_s8);
- add (builtin->builtin_real);
- add (builtin->builtin_real_s8);
- add (builtin->builtin_real_s16);
- add (builtin->builtin_complex_s8);
- add (builtin->builtin_complex_s16);
- add (builtin->builtin_void);
- lai->set_string_char_type (builtin->builtin_character);
- lai->set_bool_type (builtin->builtin_logical_s2, "logical");
- }
- /* See language.h. */
- unsigned int
- f_language::search_name_hash (const char *name) const
- {
- return cp_search_name_hash (name);
- }
- /* See language.h. */
- struct block_symbol
- f_language::lookup_symbol_nonlocal (const char *name,
- const struct block *block,
- const domain_enum domain) const
- {
- return cp_lookup_symbol_nonlocal (this, name, block, domain);
- }
- /* See language.h. */
- symbol_name_matcher_ftype *
- f_language::get_symbol_name_matcher_inner
- (const lookup_name_info &lookup_name) const
- {
- return cp_get_symbol_name_matcher (lookup_name);
- }
- /* Single instance of the Fortran language class. */
- static f_language f_language_defn;
- static void *
- build_fortran_types (struct gdbarch *gdbarch)
- {
- struct builtin_f_type *builtin_f_type
- = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
- builtin_f_type->builtin_void
- = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
- builtin_f_type->builtin_character
- = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
- builtin_f_type->builtin_logical_s1
- = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
- builtin_f_type->builtin_integer_s2
- = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
- "integer*2");
- builtin_f_type->builtin_integer_s8
- = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
- "integer*8");
- builtin_f_type->builtin_logical_s2
- = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
- "logical*2");
- builtin_f_type->builtin_logical_s8
- = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
- "logical*8");
- builtin_f_type->builtin_integer
- = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
- "integer");
- builtin_f_type->builtin_logical
- = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
- "logical*4");
- builtin_f_type->builtin_real
- = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
- "real", gdbarch_float_format (gdbarch));
- builtin_f_type->builtin_real_s8
- = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
- "real*8", gdbarch_double_format (gdbarch));
- auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
- if (fmt != nullptr)
- builtin_f_type->builtin_real_s16
- = arch_float_type (gdbarch, 128, "real*16", fmt);
- else if (gdbarch_long_double_bit (gdbarch) == 128)
- builtin_f_type->builtin_real_s16
- = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
- "real*16", gdbarch_long_double_format (gdbarch));
- else
- builtin_f_type->builtin_real_s16
- = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
- builtin_f_type->builtin_complex_s8
- = init_complex_type ("complex*8", builtin_f_type->builtin_real);
- builtin_f_type->builtin_complex_s16
- = init_complex_type ("complex*16", builtin_f_type->builtin_real_s8);
- if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR)
- builtin_f_type->builtin_complex_s32
- = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*32");
- else
- builtin_f_type->builtin_complex_s32
- = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
- return builtin_f_type;
- }
- static struct gdbarch_data *f_type_data;
- const struct builtin_f_type *
- builtin_f_type (struct gdbarch *gdbarch)
- {
- return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
- }
- /* Command-list for the "set/show fortran" prefix command. */
- static struct cmd_list_element *set_fortran_list;
- static struct cmd_list_element *show_fortran_list;
- void _initialize_f_language ();
- void
- _initialize_f_language ()
- {
- f_type_data = gdbarch_data_register_post_init (build_fortran_types);
- add_setshow_prefix_cmd
- ("fortran", no_class,
- _("Prefix command for changing Fortran-specific settings."),
- _("Generic command for showing Fortran-specific settings."),
- &set_fortran_list, &show_fortran_list,
- &setlist, &showlist);
- add_setshow_boolean_cmd ("repack-array-slices", class_vars,
- &repack_array_slices, _("\
- Enable or disable repacking of non-contiguous array slices."), _("\
- Show whether non-contiguous array slices are repacked."), _("\
- When the user requests a slice of a Fortran array then we can either return\n\
- a descriptor that describes the array in place (using the original array data\n\
- in its existing location) or the original data can be repacked (copied) to a\n\
- new location.\n\
- \n\
- When the content of the array slice is contiguous within the original array\n\
- then the result will never be repacked, but when the data for the new array\n\
- is non-contiguous within the original array repacking will only be performed\n\
- when this setting is on."),
- NULL,
- show_repack_array_slices,
- &set_fortran_list, &show_fortran_list);
- /* Debug Fortran's array slicing logic. */
- add_setshow_boolean_cmd ("fortran-array-slicing", class_maintenance,
- &fortran_array_slicing_debug, _("\
- Set debugging of Fortran array slicing."), _("\
- Show debugging of Fortran array slicing."), _("\
- When on, debugging of Fortran array slicing is enabled."),
- NULL,
- show_fortran_array_slicing_debug,
- &setdebuglist, &showdebuglist);
- }
- /* Ensures that function argument VALUE is in the appropriate form to
- pass to a Fortran function. Returns a possibly new value that should
- be used instead of VALUE.
- When IS_ARTIFICIAL is true this indicates an artificial argument,
- e.g. hidden string lengths which the GNU Fortran argument passing
- convention specifies as being passed by value.
- When IS_ARTIFICIAL is false, the argument is passed by pointer. If the
- value is already in target memory then return a value that is a pointer
- to VALUE. If VALUE is not in memory (e.g. an integer literal), allocate
- space in the target, copy VALUE in, and return a pointer to the in
- memory copy. */
- static struct value *
- fortran_argument_convert (struct value *value, bool is_artificial)
- {
- if (!is_artificial)
- {
- /* If the value is not in the inferior e.g. registers values,
- convenience variables and user input. */
- if (VALUE_LVAL (value) != lval_memory)
- {
- struct type *type = value_type (value);
- const int length = TYPE_LENGTH (type);
- const CORE_ADDR addr
- = value_as_long (value_allocate_space_in_inferior (length));
- write_memory (addr, value_contents (value).data (), length);
- struct value *val = value_from_contents_and_address
- (type, value_contents (value).data (), addr);
- return value_addr (val);
- }
- else
- return value_addr (value); /* Program variables, e.g. arrays. */
- }
- return value;
- }
- /* Prepare (and return) an argument value ready for an inferior function
- call to a Fortran function. EXP and POS are the expressions describing
- the argument to prepare. ARG_NUM is the argument number being
- prepared, with 0 being the first argument and so on. FUNC_TYPE is the
- type of the function being called.
- IS_INTERNAL_CALL_P is true if this is a call to a function of type
- TYPE_CODE_INTERNAL_FUNCTION, otherwise this parameter is false.
- NOSIDE has its usual meaning for expression parsing (see eval.c).
- Arguments in Fortran are normally passed by address, we coerce the
- arguments here rather than in value_arg_coerce as otherwise the call to
- malloc (to place the non-lvalue parameters in target memory) is hit by
- this Fortran specific logic. This results in malloc being called with a
- pointer to an integer followed by an attempt to malloc the arguments to
- malloc in target memory. Infinite recursion ensues. */
- static value *
- fortran_prepare_argument (struct expression *exp,
- expr::operation *subexp,
- int arg_num, bool is_internal_call_p,
- struct type *func_type, enum noside noside)
- {
- if (is_internal_call_p)
- return subexp->evaluate_with_coercion (exp, noside);
- bool is_artificial = ((arg_num >= func_type->num_fields ())
- ? true
- : TYPE_FIELD_ARTIFICIAL (func_type, arg_num));
- /* If this is an artificial argument, then either, this is an argument
- beyond the end of the known arguments, or possibly, there are no known
- arguments (maybe missing debug info).
- For these artificial arguments, if the user has prefixed it with '&'
- (for address-of), then lets always allow this to succeed, even if the
- argument is not actually in inferior memory. This will allow the user
- to pass arguments to a Fortran function even when there's no debug
- information.
- As we already pass the address of non-artificial arguments, all we
- need to do if skip the UNOP_ADDR operator in the expression and mark
- the argument as non-artificial. */
- if (is_artificial)
- {
- expr::unop_addr_operation *addrop
- = dynamic_cast<expr::unop_addr_operation *> (subexp);
- if (addrop != nullptr)
- {
- subexp = addrop->get_expression ().get ();
- is_artificial = false;
- }
- }
- struct value *arg_val = subexp->evaluate_with_coercion (exp, noside);
- return fortran_argument_convert (arg_val, is_artificial);
- }
- /* See f-lang.h. */
- struct type *
- fortran_preserve_arg_pointer (struct value *arg, struct type *type)
- {
- if (value_type (arg)->code () == TYPE_CODE_PTR)
- return value_type (arg);
- return type;
- }
- /* See f-lang.h. */
- CORE_ADDR
- fortran_adjust_dynamic_array_base_address_hack (struct type *type,
- CORE_ADDR address)
- {
- gdb_assert (type->code () == TYPE_CODE_ARRAY);
- /* We can't adjust the base address for arrays that have no content. */
- if (type_not_allocated (type) || type_not_associated (type))
- return address;
- int ndimensions = calc_f77_array_dims (type);
- LONGEST total_offset = 0;
- /* Walk through each of the dimensions of this array type and figure out
- if any of the dimensions are "backwards", that is the base address
- for this dimension points to the element at the highest memory
- address and the stride is negative. */
- struct type *tmp_type = type;
- for (int i = 0 ; i < ndimensions; ++i)
- {
- /* Grab the range for this dimension and extract the lower and upper
- bounds. */
- tmp_type = check_typedef (tmp_type);
- struct type *range_type = tmp_type->index_type ();
- LONGEST lowerbound, upperbound, stride;
- if (!get_discrete_bounds (range_type, &lowerbound, &upperbound))
- error ("failed to get range bounds");
- /* Figure out the stride for this dimension. */
- struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (tmp_type));
- stride = tmp_type->index_type ()->bounds ()->bit_stride ();
- if (stride == 0)
- stride = type_length_units (elt_type);
- else
- {
- int unit_size
- = gdbarch_addressable_memory_unit_size (elt_type->arch ());
- stride /= (unit_size * 8);
- }
- /* If this dimension is "backward" then figure out the offset
- adjustment required to point to the element at the lowest memory
- address, and add this to the total offset. */
- LONGEST offset = 0;
- if (stride < 0 && lowerbound < upperbound)
- offset = (upperbound - lowerbound) * stride;
- total_offset += offset;
- tmp_type = TYPE_TARGET_TYPE (tmp_type);
- }
- /* Adjust the address of this object and return it. */
- address += total_offset;
- return address;
- }
|