1100966Siwasaki/* Support for printing Fortran values for GDB, the GNU debugger. 2100966Siwasaki Copyright 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2003 3100966Siwasaki Free Software Foundation, Inc. 4100966Siwasaki Contributed by Motorola. Adapted from the C definitions by Farooq Butt 5100966Siwasaki (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs. 6100966Siwasaki 7100966Siwasaki This file is part of GDB. 8100966Siwasaki 9100966Siwasaki This program is free software; you can redistribute it and/or modify 10100966Siwasaki it under the terms of the GNU General Public License as published by 11100966Siwasaki the Free Software Foundation; either version 2 of the License, or 12100966Siwasaki (at your option) any later version. 13100966Siwasaki 14100966Siwasaki This program is distributed in the hope that it will be useful, 15100966Siwasaki but WITHOUT ANY WARRANTY; without even the implied warranty of 16100966Siwasaki MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17100966Siwasaki GNU General Public License for more details. 18100966Siwasaki 19100966Siwasaki You should have received a copy of the GNU General Public License 20100966Siwasaki along with this program; if not, write to the Free Software 21100966Siwasaki Foundation, Inc., 59 Temple Place - Suite 330, 22100966Siwasaki Boston, MA 02111-1307, USA. */ 23100966Siwasaki 24100966Siwasaki#include "defs.h" 25100966Siwasaki#include "gdb_string.h" 26100966Siwasaki#include "symtab.h" 27100966Siwasaki#include "gdbtypes.h" 28100966Siwasaki#include "expression.h" 29100966Siwasaki#include "value.h" 30100966Siwasaki#include "valprint.h" 31100966Siwasaki#include "language.h" 32100966Siwasaki#include "f-lang.h" 33100966Siwasaki#include "frame.h" 34100966Siwasaki#include "gdbcore.h" 35100966Siwasaki#include "command.h" 36100966Siwasaki#include "block.h" 37100966Siwasaki 38100966Siwasaki#if 0 39100966Siwasakistatic int there_is_a_visible_common_named (char *); 40100966Siwasaki#endif 41100966Siwasaki 42100966Siwasakiextern void _initialize_f_valprint (void); 43100966Siwasakistatic void info_common_command (char *, int); 44100966Siwasakistatic void list_all_visible_commons (char *); 45100966Siwasakistatic void f77_print_array (struct type *, char *, CORE_ADDR, 46100966Siwasaki struct ui_file *, int, int, int, 47100966Siwasaki enum val_prettyprint); 48100966Siwasakistatic void f77_print_array_1 (int, int, struct type *, char *, 49100966Siwasaki CORE_ADDR, struct ui_file *, int, int, int, 50100966Siwasaki enum val_prettyprint, 51100966Siwasaki int *elts); 52100966Siwasakistatic void f77_create_arrayprint_offset_tbl (struct type *, 53100966Siwasaki struct ui_file *); 54100966Siwasakistatic void f77_get_dynamic_length_of_aggregate (struct type *); 55100966Siwasaki 56100966Siwasakiint f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2]; 57100966Siwasaki 58100966Siwasaki/* Array which holds offsets to be applied to get a row's elements 59100966Siwasaki for a given array. Array also holds the size of each subarray. */ 60100966Siwasaki 61100966Siwasaki/* The following macro gives us the size of the nth dimension, Where 62100966Siwasaki n is 1 based. */ 63100966Siwasaki 64100966Siwasaki#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1]) 65100966Siwasaki 66100966Siwasaki/* The following gives us the offset for row n where n is 1-based. */ 67100966Siwasaki 68100966Siwasaki#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0]) 69100966Siwasaki 70100966Siwasakiint 71100966Siwasakif77_get_dynamic_lowerbound (struct type *type, int *lower_bound) 72100966Siwasaki{ 73100966Siwasaki CORE_ADDR current_frame_addr; 74100966Siwasaki CORE_ADDR ptr_to_lower_bound; 75100966Siwasaki 76100966Siwasaki switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type)) 77100966Siwasaki { 78100966Siwasaki case BOUND_BY_VALUE_ON_STACK: 79100966Siwasaki current_frame_addr = get_frame_base (deprecated_selected_frame); 80100966Siwasaki if (current_frame_addr > 0) 81100966Siwasaki { 82100966Siwasaki *lower_bound = 83100966Siwasaki read_memory_integer (current_frame_addr + 84100966Siwasaki TYPE_ARRAY_LOWER_BOUND_VALUE (type), 85100966Siwasaki 4); 86100966Siwasaki } 87100966Siwasaki else 88100966Siwasaki { 89100966Siwasaki *lower_bound = DEFAULT_LOWER_BOUND; 90100966Siwasaki return BOUND_FETCH_ERROR; 91100966Siwasaki } 92100966Siwasaki break; 93100966Siwasaki 94100966Siwasaki case BOUND_SIMPLE: 95100966Siwasaki *lower_bound = TYPE_ARRAY_LOWER_BOUND_VALUE (type); 96100966Siwasaki break; 97100966Siwasaki 98100966Siwasaki case BOUND_CANNOT_BE_DETERMINED: 99100966Siwasaki error ("Lower bound may not be '*' in F77"); 100100966Siwasaki break; 101100966Siwasaki 102100966Siwasaki case BOUND_BY_REF_ON_STACK: 103100966Siwasaki current_frame_addr = get_frame_base (deprecated_selected_frame); 104100966Siwasaki if (current_frame_addr > 0) 105100966Siwasaki { 106100966Siwasaki ptr_to_lower_bound = 107100966Siwasaki read_memory_typed_address (current_frame_addr + 108100966Siwasaki TYPE_ARRAY_LOWER_BOUND_VALUE (type), 109100966Siwasaki builtin_type_void_data_ptr); 110100966Siwasaki *lower_bound = read_memory_integer (ptr_to_lower_bound, 4); 111100966Siwasaki } 112100966Siwasaki else 113100966Siwasaki { 114100966Siwasaki *lower_bound = DEFAULT_LOWER_BOUND; 115100966Siwasaki return BOUND_FETCH_ERROR; 116100966Siwasaki } 117100966Siwasaki break; 118100966Siwasaki 119100966Siwasaki case BOUND_BY_REF_IN_REG: 120100966Siwasaki case BOUND_BY_VALUE_IN_REG: 121100966Siwasaki default: 122100966Siwasaki error ("??? unhandled dynamic array bound type ???"); 123100966Siwasaki break; 124100966Siwasaki } 125100966Siwasaki return BOUND_FETCH_OK; 126100966Siwasaki} 127100966Siwasaki 128100966Siwasakiint 129100966Siwasakif77_get_dynamic_upperbound (struct type *type, int *upper_bound) 130100966Siwasaki{ 131100966Siwasaki CORE_ADDR current_frame_addr = 0; 132100966Siwasaki CORE_ADDR ptr_to_upper_bound; 133100966Siwasaki 134100966Siwasaki switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type)) 135100966Siwasaki { 136100966Siwasaki case BOUND_BY_VALUE_ON_STACK: 137100966Siwasaki current_frame_addr = get_frame_base (deprecated_selected_frame); 138100966Siwasaki if (current_frame_addr > 0) 139100966Siwasaki { 140100966Siwasaki *upper_bound = 141100966Siwasaki read_memory_integer (current_frame_addr + 142100966Siwasaki TYPE_ARRAY_UPPER_BOUND_VALUE (type), 143100966Siwasaki 4); 144100966Siwasaki } 145100966Siwasaki else 146100966Siwasaki { 147100966Siwasaki *upper_bound = DEFAULT_UPPER_BOUND; 148100966Siwasaki return BOUND_FETCH_ERROR; 149100966Siwasaki } 150100966Siwasaki break; 151100966Siwasaki 152100966Siwasaki case BOUND_SIMPLE: 153100966Siwasaki *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type); 154100966Siwasaki break; 155100966Siwasaki 156100966Siwasaki case BOUND_CANNOT_BE_DETERMINED: 157100966Siwasaki /* we have an assumed size array on our hands. Assume that 158100966Siwasaki upper_bound == lower_bound so that we show at least 159100966Siwasaki 1 element.If the user wants to see more elements, let 160100966Siwasaki him manually ask for 'em and we'll subscript the 161100966Siwasaki array and show him */ 162100966Siwasaki f77_get_dynamic_lowerbound (type, upper_bound); 163100966Siwasaki break; 164100966Siwasaki 165100966Siwasaki case BOUND_BY_REF_ON_STACK: 166100966Siwasaki current_frame_addr = get_frame_base (deprecated_selected_frame); 167100966Siwasaki if (current_frame_addr > 0) 168100966Siwasaki { 169100966Siwasaki ptr_to_upper_bound = 170100966Siwasaki read_memory_typed_address (current_frame_addr + 171100966Siwasaki TYPE_ARRAY_UPPER_BOUND_VALUE (type), 172100966Siwasaki builtin_type_void_data_ptr); 173100966Siwasaki *upper_bound = read_memory_integer (ptr_to_upper_bound, 4); 174100966Siwasaki } 175100966Siwasaki else 176100966Siwasaki { 177100966Siwasaki *upper_bound = DEFAULT_UPPER_BOUND; 178100966Siwasaki return BOUND_FETCH_ERROR; 179100966Siwasaki } 180100966Siwasaki break; 181100966Siwasaki 182100966Siwasaki case BOUND_BY_REF_IN_REG: 183100966Siwasaki case BOUND_BY_VALUE_IN_REG: 184100966Siwasaki default: 185100966Siwasaki error ("??? unhandled dynamic array bound type ???"); 186100966Siwasaki break; 187100966Siwasaki } 188100966Siwasaki return BOUND_FETCH_OK; 189100966Siwasaki} 190100966Siwasaki 191100966Siwasaki/* Obtain F77 adjustable array dimensions */ 192100966Siwasaki 193100966Siwasakistatic void 194100966Siwasakif77_get_dynamic_length_of_aggregate (struct type *type) 195100966Siwasaki{ 196100966Siwasaki int upper_bound = -1; 197100966Siwasaki int lower_bound = 1; 198100966Siwasaki int retcode; 199100966Siwasaki 200100966Siwasaki /* Recursively go all the way down into a possibly multi-dimensional 201100966Siwasaki F77 array and get the bounds. For simple arrays, this is pretty 202100966Siwasaki easy but when the bounds are dynamic, we must be very careful 203100966Siwasaki to add up all the lengths correctly. Not doing this right 204100966Siwasaki will lead to horrendous-looking arrays in parameter lists. 205100966Siwasaki 206100966Siwasaki This function also works for strings which behave very 207100966Siwasaki similarly to arrays. */ 208100966Siwasaki 209100966Siwasaki if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY 210100966Siwasaki || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING) 211100966Siwasaki f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type)); 212100966Siwasaki 213100966Siwasaki /* Recursion ends here, start setting up lengths. */ 214100966Siwasaki retcode = f77_get_dynamic_lowerbound (type, &lower_bound); 215100966Siwasaki if (retcode == BOUND_FETCH_ERROR) 216100966Siwasaki error ("Cannot obtain valid array lower bound"); 217100966Siwasaki 218100966Siwasaki retcode = f77_get_dynamic_upperbound (type, &upper_bound); 219100966Siwasaki if (retcode == BOUND_FETCH_ERROR) 220100966Siwasaki error ("Cannot obtain valid array upper bound"); 221100966Siwasaki 222100966Siwasaki /* Patch in a valid length value. */ 223100966Siwasaki 224100966Siwasaki TYPE_LENGTH (type) = 225100966Siwasaki (upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type))); 226100966Siwasaki} 227100966Siwasaki 228100966Siwasaki/* Function that sets up the array offset,size table for the array 229100966Siwasaki type "type". */ 230100966Siwasaki 231100966Siwasakistatic void 232100966Siwasakif77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream) 233100966Siwasaki{ 234100966Siwasaki struct type *tmp_type; 235100966Siwasaki int eltlen; 236100966Siwasaki int ndimen = 1; 237100966Siwasaki int upper, lower, retcode; 238100966Siwasaki 239100966Siwasaki tmp_type = type; 240100966Siwasaki 241100966Siwasaki while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)) 242100966Siwasaki { 243100966Siwasaki if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED) 244100966Siwasaki fprintf_filtered (stream, "<assumed size array> "); 245100966Siwasaki 246100966Siwasaki retcode = f77_get_dynamic_upperbound (tmp_type, &upper); 247100966Siwasaki if (retcode == BOUND_FETCH_ERROR) 248100966Siwasaki error ("Cannot obtain dynamic upper bound"); 249100966Siwasaki 250100966Siwasaki retcode = f77_get_dynamic_lowerbound (tmp_type, &lower); 251100966Siwasaki if (retcode == BOUND_FETCH_ERROR) 252100966Siwasaki error ("Cannot obtain dynamic lower bound"); 253100966Siwasaki 254100966Siwasaki F77_DIM_SIZE (ndimen) = upper - lower + 1; 255100966Siwasaki 256100966Siwasaki tmp_type = TYPE_TARGET_TYPE (tmp_type); 257100966Siwasaki ndimen++; 258100966Siwasaki } 259100966Siwasaki 260100966Siwasaki /* Now we multiply eltlen by all the offsets, so that later we 261100966Siwasaki can print out array elements correctly. Up till now we 262100966Siwasaki know an offset to apply to get the item but we also 263100966Siwasaki have to know how much to add to get to the next item */ 264100966Siwasaki 265100966Siwasaki ndimen--; 266100966Siwasaki eltlen = TYPE_LENGTH (tmp_type); 267100966Siwasaki F77_DIM_OFFSET (ndimen) = eltlen; 268100966Siwasaki while (--ndimen > 0) 269100966Siwasaki { 270100966Siwasaki eltlen *= F77_DIM_SIZE (ndimen + 1); 271100966Siwasaki F77_DIM_OFFSET (ndimen) = eltlen; 272100966Siwasaki } 273100966Siwasaki} 274100966Siwasaki 275100966Siwasaki 276100966Siwasaki 277100966Siwasaki/* Actual function which prints out F77 arrays, Valaddr == address in 278100966Siwasaki the superior. Address == the address in the inferior. */ 279100966Siwasaki 280100966Siwasakistatic void 281100966Siwasakif77_print_array_1 (int nss, int ndimensions, struct type *type, char *valaddr, 282100966Siwasaki CORE_ADDR address, struct ui_file *stream, int format, 283100966Siwasaki int deref_ref, int recurse, enum val_prettyprint pretty, 284100966Siwasaki int *elts) 285100966Siwasaki{ 286100966Siwasaki int i; 287100966Siwasaki 288100966Siwasaki if (nss != ndimensions) 289100966Siwasaki { 290100966Siwasaki for (i = 0; (i < F77_DIM_SIZE (nss) && (*elts) < print_max); i++) 291100966Siwasaki { 292100966Siwasaki fprintf_filtered (stream, "( "); 293100966Siwasaki f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type), 294100966Siwasaki valaddr + i * F77_DIM_OFFSET (nss), 295100966Siwasaki address + i * F77_DIM_OFFSET (nss), 296100966Siwasaki stream, format, deref_ref, recurse, pretty, elts); 297100966Siwasaki fprintf_filtered (stream, ") "); 298100966Siwasaki } 299100966Siwasaki if (*elts >= print_max && i < F77_DIM_SIZE (nss)) 300100966Siwasaki fprintf_filtered (stream, "..."); 301100966Siwasaki } 302100966Siwasaki else 303100966Siwasaki { 304100966Siwasaki for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < print_max; 305100966Siwasaki i++, (*elts)++) 306100966Siwasaki { 307100966Siwasaki val_print (TYPE_TARGET_TYPE (type), 308100966Siwasaki valaddr + i * F77_DIM_OFFSET (ndimensions), 309100966Siwasaki 0, 310100966Siwasaki address + i * F77_DIM_OFFSET (ndimensions), 311100966Siwasaki stream, format, deref_ref, recurse, pretty); 312100966Siwasaki 313100966Siwasaki if (i != (F77_DIM_SIZE (nss) - 1)) 314100966Siwasaki fprintf_filtered (stream, ", "); 315100966Siwasaki 316100966Siwasaki if ((*elts == print_max - 1) && (i != (F77_DIM_SIZE (nss) - 1))) 317100966Siwasaki fprintf_filtered (stream, "..."); 318100966Siwasaki } 319100966Siwasaki } 320100966Siwasaki} 321100966Siwasaki 322100966Siwasaki/* This function gets called to print an F77 array, we set up some 323100966Siwasaki stuff and then immediately call f77_print_array_1() */ 324100966Siwasaki 325100966Siwasakistatic void 326100966Siwasakif77_print_array (struct type *type, char *valaddr, CORE_ADDR address, 327100966Siwasaki struct ui_file *stream, int format, int deref_ref, int recurse, 328100966Siwasaki enum val_prettyprint pretty) 329100966Siwasaki{ 330100966Siwasaki int ndimensions; 331100966Siwasaki int elts = 0; 332100966Siwasaki 333100966Siwasaki ndimensions = calc_f77_array_dims (type); 334100966Siwasaki 335100966Siwasaki if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0) 336100966Siwasaki error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)", 337100966Siwasaki ndimensions, MAX_FORTRAN_DIMS); 338100966Siwasaki 339100966Siwasaki /* Since F77 arrays are stored column-major, we set up an 340100966Siwasaki offset table to get at the various row's elements. The 341100966Siwasaki offset table contains entries for both offset and subarray size. */ 342100966Siwasaki 343100966Siwasaki f77_create_arrayprint_offset_tbl (type, stream); 344100966Siwasaki 345100966Siwasaki f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format, 346100966Siwasaki deref_ref, recurse, pretty, &elts); 347100966Siwasaki} 348100966Siwasaki 349100966Siwasaki 350100966Siwasaki/* Print data of type TYPE located at VALADDR (within GDB), which came from 351100966Siwasaki the inferior at address ADDRESS, onto stdio stream STREAM according to 352100966Siwasaki FORMAT (a letter or 0 for natural format). The data at VALADDR is in 353100966Siwasaki target byte order. 354100966Siwasaki 355100966Siwasaki If the data are a string pointer, returns the number of string characters 356100966Siwasaki printed. 357100966Siwasaki 358100966Siwasaki If DEREF_REF is nonzero, then dereference references, otherwise just print 359100966Siwasaki them like pointers. 360100966Siwasaki 361100966Siwasaki The PRETTY parameter controls prettyprinting. */ 362100966Siwasaki 363100966Siwasakiint 364100966Siwasakif_val_print (struct type *type, char *valaddr, int embedded_offset, 365100966Siwasaki CORE_ADDR address, struct ui_file *stream, int format, 366100966Siwasaki int deref_ref, int recurse, enum val_prettyprint pretty) 367100966Siwasaki{ 368100966Siwasaki unsigned int i = 0; /* Number of characters printed */ 369100966Siwasaki struct type *elttype; 370100966Siwasaki LONGEST val; 371100966Siwasaki CORE_ADDR addr; 372100966Siwasaki 373100966Siwasaki CHECK_TYPEDEF (type); 374100966Siwasaki switch (TYPE_CODE (type)) 375100966Siwasaki { 376100966Siwasaki case TYPE_CODE_STRING: 377100966Siwasaki f77_get_dynamic_length_of_aggregate (type); 378100966Siwasaki LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0); 379100966Siwasaki break; 380100966Siwasaki 381100966Siwasaki case TYPE_CODE_ARRAY: 382100966Siwasaki fprintf_filtered (stream, "("); 383100966Siwasaki f77_print_array (type, valaddr, address, stream, format, 384100966Siwasaki deref_ref, recurse, pretty); 385100966Siwasaki fprintf_filtered (stream, ")"); 386100966Siwasaki break; 387100966Siwasaki 388100966Siwasaki case TYPE_CODE_PTR: 389100966Siwasaki if (format && format != 's') 390100966Siwasaki { 391100966Siwasaki print_scalar_formatted (valaddr, type, format, 0, stream); 392100966Siwasaki break; 393100966Siwasaki } 394100966Siwasaki else 395100966Siwasaki { 396100966Siwasaki addr = unpack_pointer (type, valaddr); 397100966Siwasaki elttype = check_typedef (TYPE_TARGET_TYPE (type)); 398100966Siwasaki 399100966Siwasaki if (TYPE_CODE (elttype) == TYPE_CODE_FUNC) 400100966Siwasaki { 401100966Siwasaki /* Try to print what function it points to. */ 402100966Siwasaki print_address_demangle (addr, stream, demangle); 403100966Siwasaki /* Return value is irrelevant except for string pointers. */ 404100966Siwasaki return 0; 405100966Siwasaki } 406100966Siwasaki 407100966Siwasaki if (addressprint && format != 's') 408100966Siwasaki print_address_numeric (addr, 1, stream); 409100966Siwasaki 410100966Siwasaki /* For a pointer to char or unsigned char, also print the string 411100966Siwasaki pointed to, unless pointer is null. */ 412100966Siwasaki if (TYPE_LENGTH (elttype) == 1 413100966Siwasaki && TYPE_CODE (elttype) == TYPE_CODE_INT 414100966Siwasaki && (format == 0 || format == 's') 415100966Siwasaki && addr != 0) 416100966Siwasaki i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream); 417100966Siwasaki 418100966Siwasaki /* Return number of characters printed, including the terminating 419100966Siwasaki '\0' if we reached the end. val_print_string takes care including 420100966Siwasaki the terminating '\0' if necessary. */ 421100966Siwasaki return i; 422100966Siwasaki } 423100966Siwasaki break; 424100966Siwasaki 425100966Siwasaki case TYPE_CODE_REF: 426100966Siwasaki elttype = check_typedef (TYPE_TARGET_TYPE (type)); 427100966Siwasaki if (addressprint) 428100966Siwasaki { 429100966Siwasaki CORE_ADDR addr 430100966Siwasaki = extract_typed_address (valaddr + embedded_offset, type); 431100966Siwasaki fprintf_filtered (stream, "@"); 432100966Siwasaki print_address_numeric (addr, 1, stream); 433100966Siwasaki if (deref_ref) 434100966Siwasaki fputs_filtered (": ", stream); 435100966Siwasaki } 436100966Siwasaki /* De-reference the reference. */ 437100966Siwasaki if (deref_ref) 438100966Siwasaki { 439100966Siwasaki if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF) 440100966Siwasaki { 441100966Siwasaki struct value *deref_val = 442100966Siwasaki value_at 443100966Siwasaki (TYPE_TARGET_TYPE (type), 444100966Siwasaki unpack_pointer (lookup_pointer_type (builtin_type_void), 445100966Siwasaki valaddr + embedded_offset), 446100966Siwasaki NULL); 447100966Siwasaki common_val_print (deref_val, stream, format, deref_ref, recurse, 448100966Siwasaki pretty); 449100966Siwasaki } 450100966Siwasaki else 451100966Siwasaki fputs_filtered ("???", stream); 452100966Siwasaki } 453100966Siwasaki break; 454100966Siwasaki 455100966Siwasaki case TYPE_CODE_FUNC: 456100966Siwasaki if (format) 457100966Siwasaki { 458100966Siwasaki print_scalar_formatted (valaddr, type, format, 0, stream); 459100966Siwasaki break; 460100966Siwasaki } 461100966Siwasaki /* FIXME, we should consider, at least for ANSI C language, eliminating 462100966Siwasaki the distinction made between FUNCs and POINTERs to FUNCs. */ 463100966Siwasaki fprintf_filtered (stream, "{"); 464100966Siwasaki type_print (type, "", stream, -1); 465100966Siwasaki fprintf_filtered (stream, "} "); 466100966Siwasaki /* Try to print what function it points to, and its address. */ 467100966Siwasaki print_address_demangle (address, stream, demangle); 468100966Siwasaki break; 469100966Siwasaki 470100966Siwasaki case TYPE_CODE_INT: 471100966Siwasaki format = format ? format : output_format; 472100966Siwasaki if (format) 473100966Siwasaki print_scalar_formatted (valaddr, type, format, 0, stream); 474100966Siwasaki else 475100966Siwasaki { 476100966Siwasaki val_print_type_code_int (type, valaddr, stream); 477100966Siwasaki /* C and C++ has no single byte int type, char is used instead. 478100966Siwasaki Since we don't know whether the value is really intended to 479100966Siwasaki be used as an integer or a character, print the character 480100966Siwasaki equivalent as well. */ 481100966Siwasaki if (TYPE_LENGTH (type) == 1) 482100966Siwasaki { 483100966Siwasaki fputs_filtered (" ", stream); 484100966Siwasaki LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr), 485100966Siwasaki stream); 486100966Siwasaki } 487100966Siwasaki } 488100966Siwasaki break; 489100966Siwasaki 490100966Siwasaki case TYPE_CODE_FLT: 491100966Siwasaki if (format) 492100966Siwasaki print_scalar_formatted (valaddr, type, format, 0, stream); 493100966Siwasaki else 494100966Siwasaki print_floating (valaddr, type, stream); 495100966Siwasaki break; 496100966Siwasaki 497100966Siwasaki case TYPE_CODE_VOID: 498100966Siwasaki fprintf_filtered (stream, "VOID"); 499100966Siwasaki break; 500100966Siwasaki 501100966Siwasaki case TYPE_CODE_ERROR: 502100966Siwasaki fprintf_filtered (stream, "<error type>"); 503100966Siwasaki break; 504100966Siwasaki 505100966Siwasaki case TYPE_CODE_RANGE: 506100966Siwasaki /* FIXME, we should not ever have to print one of these yet. */ 507100966Siwasaki fprintf_filtered (stream, "<range type>"); 508100966Siwasaki break; 509100966Siwasaki 510100966Siwasaki case TYPE_CODE_BOOL: 511100966Siwasaki format = format ? format : output_format; 512100966Siwasaki if (format) 513100966Siwasaki print_scalar_formatted (valaddr, type, format, 0, stream); 514100966Siwasaki else 515100966Siwasaki { 516100966Siwasaki val = 0; 517100966Siwasaki switch (TYPE_LENGTH (type)) 518100966Siwasaki { 519100966Siwasaki case 1: 520100966Siwasaki val = unpack_long (builtin_type_f_logical_s1, valaddr); 521100966Siwasaki break; 522100966Siwasaki 523100966Siwasaki case 2: 524100966Siwasaki val = unpack_long (builtin_type_f_logical_s2, valaddr); 525100966Siwasaki break; 526100966Siwasaki 527100966Siwasaki case 4: 528100966Siwasaki val = unpack_long (builtin_type_f_logical, valaddr); 529100966Siwasaki break; 530100966Siwasaki 531100966Siwasaki default: 532100966Siwasaki error ("Logicals of length %d bytes not supported", 533100966Siwasaki TYPE_LENGTH (type)); 534100966Siwasaki 535100966Siwasaki } 536100966Siwasaki 537100966Siwasaki if (val == 0) 538100966Siwasaki fprintf_filtered (stream, ".FALSE."); 539100966Siwasaki else if (val == 1) 540100966Siwasaki fprintf_filtered (stream, ".TRUE."); 541100966Siwasaki else 542100966Siwasaki /* Not a legitimate logical type, print as an integer. */ 543100966Siwasaki { 544100966Siwasaki /* Bash the type code temporarily. */ 545100966Siwasaki TYPE_CODE (type) = TYPE_CODE_INT; 546100966Siwasaki f_val_print (type, valaddr, 0, address, stream, format, 547100966Siwasaki deref_ref, recurse, pretty); 548100966Siwasaki /* Restore the type code so later uses work as intended. */ 549100966Siwasaki TYPE_CODE (type) = TYPE_CODE_BOOL; 550100966Siwasaki } 551100966Siwasaki } 552100966Siwasaki break; 553100966Siwasaki 554100966Siwasaki case TYPE_CODE_COMPLEX: 555100966Siwasaki switch (TYPE_LENGTH (type)) 556100966Siwasaki { 557100966Siwasaki case 8: 558100966Siwasaki type = builtin_type_f_real; 559100966Siwasaki break; 560100966Siwasaki case 16: 561100966Siwasaki type = builtin_type_f_real_s8; 562100966Siwasaki break; 563100966Siwasaki case 32: 564100966Siwasaki type = builtin_type_f_real_s16; 565100966Siwasaki break; 566100966Siwasaki default: 567100966Siwasaki error ("Cannot print out complex*%d variables", TYPE_LENGTH (type)); 568100966Siwasaki } 569100966Siwasaki fputs_filtered ("(", stream); 570100966Siwasaki print_floating (valaddr, type, stream); 571100966Siwasaki fputs_filtered (",", stream); 572100966Siwasaki print_floating (valaddr + TYPE_LENGTH (type), type, stream); 573100966Siwasaki fputs_filtered (")", stream); 574100966Siwasaki break; 575100966Siwasaki 576100966Siwasaki case TYPE_CODE_UNDEF: 577100966Siwasaki /* This happens (without TYPE_FLAG_STUB set) on systems which don't use 578100966Siwasaki dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar" 579100966Siwasaki and no complete type for struct foo in that file. */ 580100966Siwasaki fprintf_filtered (stream, "<incomplete type>"); 581100966Siwasaki break; 582100966Siwasaki 583100966Siwasaki default: 584100966Siwasaki error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type)); 585100966Siwasaki } 586100966Siwasaki gdb_flush (stream); 587100966Siwasaki return 0; 588100966Siwasaki} 589100966Siwasaki 590100966Siwasakistatic void 591100966Siwasakilist_all_visible_commons (char *funname) 592100966Siwasaki{ 593100966Siwasaki SAVED_F77_COMMON_PTR tmp; 594100966Siwasaki 595100966Siwasaki tmp = head_common_list; 596100966Siwasaki 597100966Siwasaki printf_filtered ("All COMMON blocks visible at this level:\n\n"); 598100966Siwasaki 599100966Siwasaki while (tmp != NULL) 600100966Siwasaki { 601100966Siwasaki if (strcmp (tmp->owning_function, funname) == 0) 602100966Siwasaki printf_filtered ("%s\n", tmp->name); 603100966Siwasaki 604100966Siwasaki tmp = tmp->next; 605100966Siwasaki } 606100966Siwasaki} 607100966Siwasaki 608100966Siwasaki/* This function is used to print out the values in a given COMMON 609100966Siwasaki block. It will always use the most local common block of the 610100966Siwasaki given name */ 611100966Siwasaki 612100966Siwasakistatic void 613100966Siwasakiinfo_common_command (char *comname, int from_tty) 614100966Siwasaki{ 615100966Siwasaki SAVED_F77_COMMON_PTR the_common; 616100966Siwasaki COMMON_ENTRY_PTR entry; 617100966Siwasaki struct frame_info *fi; 618100966Siwasaki char *funname = 0; 619100966Siwasaki struct symbol *func; 620100966Siwasaki 621100966Siwasaki /* We have been told to display the contents of F77 COMMON 622100966Siwasaki block supposedly visible in this function. Let us 623100966Siwasaki first make sure that it is visible and if so, let 624100966Siwasaki us display its contents */ 625100966Siwasaki 626100966Siwasaki fi = deprecated_selected_frame; 627100966Siwasaki 628100966Siwasaki if (fi == NULL) 629100966Siwasaki error ("No frame selected"); 630100966Siwasaki 631100966Siwasaki /* The following is generally ripped off from stack.c's routine 632100966Siwasaki print_frame_info() */ 633100966Siwasaki 634100966Siwasaki func = find_pc_function (get_frame_pc (fi)); 635100966Siwasaki if (func) 636100966Siwasaki { 637100966Siwasaki /* In certain pathological cases, the symtabs give the wrong 638100966Siwasaki function (when we are in the first function in a file which 639100966Siwasaki is compiled without debugging symbols, the previous function 640100966Siwasaki is compiled with debugging symbols, and the "foo.o" symbol 641100966Siwasaki that is supposed to tell us where the file with debugging symbols 642100966Siwasaki ends has been truncated by ar because it is longer than 15 643100966Siwasaki characters). 644100966Siwasaki 645100966Siwasaki So look in the minimal symbol tables as well, and if it comes 646100966Siwasaki up with a larger address for the function use that instead. 647100966Siwasaki I don't think this can ever cause any problems; there shouldn't 648100966Siwasaki be any minimal symbols in the middle of a function. 649100966Siwasaki FIXME: (Not necessarily true. What about text labels) */ 650100966Siwasaki 651100966Siwasaki struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (get_frame_pc (fi)); 652100966Siwasaki 653100966Siwasaki if (msymbol != NULL 654100966Siwasaki && (SYMBOL_VALUE_ADDRESS (msymbol) 655100966Siwasaki > BLOCK_START (SYMBOL_BLOCK_VALUE (func)))) 656100966Siwasaki funname = DEPRECATED_SYMBOL_NAME (msymbol); 657100966Siwasaki else 658100966Siwasaki funname = DEPRECATED_SYMBOL_NAME (func); 659100966Siwasaki } 660100966Siwasaki else 661100966Siwasaki { 662100966Siwasaki struct minimal_symbol *msymbol = 663100966Siwasaki lookup_minimal_symbol_by_pc (get_frame_pc (fi)); 664100966Siwasaki 665100966Siwasaki if (msymbol != NULL) 666100966Siwasaki funname = DEPRECATED_SYMBOL_NAME (msymbol); 667100966Siwasaki } 668100966Siwasaki 669100966Siwasaki /* If comname is NULL, we assume the user wishes to see the 670100966Siwasaki which COMMON blocks are visible here and then return */ 671100966Siwasaki 672100966Siwasaki if (comname == 0) 673100966Siwasaki { 674100966Siwasaki list_all_visible_commons (funname); 675100966Siwasaki return; 676100966Siwasaki } 677100966Siwasaki 678100966Siwasaki the_common = find_common_for_function (comname, funname); 679100966Siwasaki 680100966Siwasaki if (the_common) 681100966Siwasaki { 682100966Siwasaki if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0) 683100966Siwasaki printf_filtered ("Contents of blank COMMON block:\n"); 684100966Siwasaki else 685100966Siwasaki printf_filtered ("Contents of F77 COMMON block '%s':\n", comname); 686100966Siwasaki 687100966Siwasaki printf_filtered ("\n"); 688100966Siwasaki entry = the_common->entries; 689100966Siwasaki 690100966Siwasaki while (entry != NULL) 691100966Siwasaki { 692100966Siwasaki printf_filtered ("%s = ", DEPRECATED_SYMBOL_NAME (entry->symbol)); 693100966Siwasaki print_variable_value (entry->symbol, fi, gdb_stdout); 694100966Siwasaki printf_filtered ("\n"); 695100966Siwasaki entry = entry->next; 696100966Siwasaki } 697100966Siwasaki } 698100966Siwasaki else 699100966Siwasaki printf_filtered ("Cannot locate the common block %s in function '%s'\n", 700100966Siwasaki comname, funname); 701100966Siwasaki} 702100966Siwasaki 703100966Siwasaki/* This function is used to determine whether there is a 704100966Siwasaki F77 common block visible at the current scope called 'comname'. */ 705100966Siwasaki 706100966Siwasaki#if 0 707100966Siwasakistatic int 708100966Siwasakithere_is_a_visible_common_named (char *comname) 709100966Siwasaki{ 710100966Siwasaki SAVED_F77_COMMON_PTR the_common; 711100966Siwasaki struct frame_info *fi; 712100966Siwasaki char *funname = 0; 713100966Siwasaki struct symbol *func; 714100966Siwasaki 715100966Siwasaki if (comname == NULL) 716100966Siwasaki error ("Cannot deal with NULL common name!"); 717100966Siwasaki 718100966Siwasaki fi = deprecated_selected_frame; 719100966Siwasaki 720100966Siwasaki if (fi == NULL) 721100966Siwasaki error ("No frame selected"); 722100966Siwasaki 723100966Siwasaki /* The following is generally ripped off from stack.c's routine 724100966Siwasaki print_frame_info() */ 725100966Siwasaki 726100966Siwasaki func = find_pc_function (fi->pc); 727100966Siwasaki if (func) 728100966Siwasaki { 729100966Siwasaki /* In certain pathological cases, the symtabs give the wrong 730100966Siwasaki function (when we are in the first function in a file which 731100966Siwasaki is compiled without debugging symbols, the previous function 732100966Siwasaki is compiled with debugging symbols, and the "foo.o" symbol 733100966Siwasaki that is supposed to tell us where the file with debugging symbols 734100966Siwasaki ends has been truncated by ar because it is longer than 15 735100966Siwasaki characters). 736100966Siwasaki 737100966Siwasaki So look in the minimal symbol tables as well, and if it comes 738100966Siwasaki up with a larger address for the function use that instead. 739100966Siwasaki I don't think this can ever cause any problems; there shouldn't 740100966Siwasaki be any minimal symbols in the middle of a function. 741100966Siwasaki FIXME: (Not necessarily true. What about text labels) */ 742100966Siwasaki 743100966Siwasaki struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc); 744100966Siwasaki 745100966Siwasaki if (msymbol != NULL 746100966Siwasaki && (SYMBOL_VALUE_ADDRESS (msymbol) 747100966Siwasaki > BLOCK_START (SYMBOL_BLOCK_VALUE (func)))) 748100966Siwasaki funname = DEPRECATED_SYMBOL_NAME (msymbol); 749100966Siwasaki else 750100966Siwasaki funname = DEPRECATED_SYMBOL_NAME (func); 751100966Siwasaki } 752100966Siwasaki else 753100966Siwasaki { 754100966Siwasaki struct minimal_symbol *msymbol = 755100966Siwasaki lookup_minimal_symbol_by_pc (fi->pc); 756100966Siwasaki 757100966Siwasaki if (msymbol != NULL) 758100966Siwasaki funname = DEPRECATED_SYMBOL_NAME (msymbol); 759100966Siwasaki } 760100966Siwasaki 761100966Siwasaki the_common = find_common_for_function (comname, funname); 762100966Siwasaki 763100966Siwasaki return (the_common ? 1 : 0); 764100966Siwasaki} 765100966Siwasaki#endif 766100966Siwasaki 767100966Siwasakivoid 768100966Siwasaki_initialize_f_valprint (void) 769100966Siwasaki{ 770100966Siwasaki add_info ("common", info_common_command, 771100966Siwasaki "Print out the values contained in a Fortran COMMON block."); 772100966Siwasaki if (xdb_commands) 773100966Siwasaki add_com ("lc", class_info, info_common_command, 774100966Siwasaki "Print out the values contained in a Fortran COMMON block."); 775100966Siwasaki} 776100966Siwasaki