-/* Pascal language support routines for GDB, the GNU debugger.
- Copyright 2000 Free Software Foundation, Inc.
-
- 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 2 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, write to the Free Software
- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
-
-/* This file is derived from p-lang.c */
-
-#include "defs.h"
-#include "symtab.h"
-#include "gdbtypes.h"
-#include "expression.h"
-#include "parser-defs.h"
-#include "language.h"
-#include "p-lang.h"
-#include "valprint.h"
-
-extern void _initialize_pascal_language (void);
-static void pascal_one_char (int, struct ui_file *, int *);
-
-/* Print the character C on STREAM as part of the contents of a literal
- string.
- In_quotes is reset to 0 if a char is written with #4 notation */
-
-static void
-pascal_one_char (register int c, struct ui_file *stream, int *in_quotes)
-{
-
- c &= 0xFF; /* Avoid sign bit follies */
-
- if ((c == '\'') || (PRINT_LITERAL_FORM (c)))
- {
- if (!(*in_quotes))
- fputs_filtered ("'", stream);
- *in_quotes = 1;
- if (c == '\'')
- {
- fputs_filtered ("''", stream);
- }
- else
- fprintf_filtered (stream, "%c", c);
- }
- else
- {
- if (*in_quotes)
- fputs_filtered ("'", stream);
- *in_quotes = 0;
- fprintf_filtered (stream, "#%d", (unsigned int) c);
- }
-}
-
-static void pascal_emit_char (int c, struct ui_file *stream, int quoter);
-
-/* Print the character C on STREAM as part of the contents of a literal
- string whose delimiter is QUOTER. Note that that format for printing
- characters and strings is language specific. */
-
-static void
-pascal_emit_char (register int c, struct ui_file *stream, int quoter)
-{
- int in_quotes = 0;
- pascal_one_char (c, stream, &in_quotes);
- if (in_quotes)
- fputs_filtered ("'", stream);
-}
-
-void
-pascal_printchar (int c, struct ui_file *stream)
-{
- int in_quotes = 0;
- pascal_one_char (c, stream, &in_quotes);
- if (in_quotes)
- fputs_filtered ("'", stream);
-}
-
-/* Print the character string STRING, printing at most LENGTH characters.
- Printing stops early if the number hits print_max; repeat counts
- are printed as appropriate. Print ellipses at the end if we
- had to stop before printing LENGTH characters, or if FORCE_ELLIPSES. */
-
-void
-pascal_printstr (struct ui_file *stream, char *string, unsigned int length,
- int width, int force_ellipses)
-{
- register unsigned int i;
- unsigned int things_printed = 0;
- int in_quotes = 0;
- int need_comma = 0;
- extern int inspect_it;
-
- /* If the string was not truncated due to `set print elements', and
- the last byte of it is a null, we don't print that, in traditional C
- style. */
- if ((!force_ellipses) && length > 0 && string[length - 1] == '\0')
- length--;
-
- if (length == 0)
- {
- fputs_filtered ("''", stream);
- return;
- }
-
- for (i = 0; i < length && things_printed < print_max; ++i)
- {
- /* Position of the character we are examining
- to see whether it is repeated. */
- unsigned int rep1;
- /* Number of repetitions we have detected so far. */
- unsigned int reps;
-
- QUIT;
-
- if (need_comma)
- {
- fputs_filtered (", ", stream);
- need_comma = 0;
- }
-
- rep1 = i + 1;
- reps = 1;
- while (rep1 < length && string[rep1] == string[i])
- {
- ++rep1;
- ++reps;
- }
-
- if (reps > repeat_count_threshold)
- {
- if (in_quotes)
- {
- if (inspect_it)
- fputs_filtered ("\\', ", stream);
- else
- fputs_filtered ("', ", stream);
- in_quotes = 0;
- }
- pascal_printchar (string[i], stream);
- fprintf_filtered (stream, " <repeats %u times>", reps);
- i = rep1 - 1;
- things_printed += repeat_count_threshold;
- need_comma = 1;
- }
- else
- {
- int c = string[i];
- if ((!in_quotes) && (PRINT_LITERAL_FORM (c)))
- {
- if (inspect_it)
- fputs_filtered ("\\'", stream);
- else
- fputs_filtered ("'", stream);
- in_quotes = 1;
- }
- pascal_one_char (c, stream, &in_quotes);
- ++things_printed;
- }
- }
-
- /* Terminate the quotes if necessary. */
- if (in_quotes)
- {
- if (inspect_it)
- fputs_filtered ("\\'", stream);
- else
- fputs_filtered ("'", stream);
- }
-
- if (force_ellipses || i < length)
- fputs_filtered ("...", stream);
-}
-
-/* Create a fundamental Pascal type using default reasonable for the current
- target machine.
-
- Some object/debugging file formats (DWARF version 1, COFF, etc) do not
- define fundamental types such as "int" or "double". Others (stabs or
- DWARF version 2, etc) do define fundamental types. For the formats which
- don't provide fundamental types, gdb can create such types using this
- function.
-
- FIXME: Some compilers distinguish explicitly signed integral types
- (signed short, signed int, signed long) from "regular" integral types
- (short, int, long) in the debugging information. There is some dis-
- agreement as to how useful this feature is. In particular, gcc does
- not support this. Also, only some debugging formats allow the
- distinction to be passed on to a debugger. For now, we always just
- use "short", "int", or "long" as the type name, for both the implicit
- and explicitly signed types. This also makes life easier for the
- gdb test suite since we don't have to account for the differences
- in output depending upon what the compiler and debugging format
- support. We will probably have to re-examine the issue when gdb
- starts taking it's fundamental type information directly from the
- debugging information supplied by the compiler. fnf@cygnus.com */
-
-/* Note there might be some discussion about the choosen correspondance
- because it mainly reflects Free Pascal Compiler setup for now PM */
-
-
-struct type *
-pascal_create_fundamental_type (struct objfile *objfile, int typeid)
-{
- register struct type *type = NULL;
-
- switch (typeid)
- {
- default:
- /* FIXME: For now, if we are asked to produce a type not in this
- language, create the equivalent of a C integer type with the
- name "<?type?>". When all the dust settles from the type
- reconstruction work, this should probably become an error. */
- type = init_type (TYPE_CODE_INT,
- TARGET_INT_BIT / TARGET_CHAR_BIT,
- 0, "<?type?>", objfile);
- warning ("internal error: no Pascal fundamental type %d", typeid);
- break;
- case FT_VOID:
- type = init_type (TYPE_CODE_VOID,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "void", objfile);
- break;
- case FT_CHAR:
- type = init_type (TYPE_CODE_INT,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "char", objfile);
- break;
- case FT_SIGNED_CHAR:
- type = init_type (TYPE_CODE_INT,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "shortint", objfile);
- break;
- case FT_UNSIGNED_CHAR:
- type = init_type (TYPE_CODE_INT,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "byte", objfile);
- break;
- case FT_SHORT:
- type = init_type (TYPE_CODE_INT,
- TARGET_SHORT_BIT / TARGET_CHAR_BIT,
- 0, "integer", objfile);
- break;
- case FT_SIGNED_SHORT:
- type = init_type (TYPE_CODE_INT,
- TARGET_SHORT_BIT / TARGET_CHAR_BIT,
- 0, "integer", objfile); /* FIXME-fnf */
- break;
- case FT_UNSIGNED_SHORT:
- type = init_type (TYPE_CODE_INT,
- TARGET_SHORT_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "word", objfile);
- break;
- case FT_INTEGER:
- type = init_type (TYPE_CODE_INT,
- TARGET_INT_BIT / TARGET_CHAR_BIT,
- 0, "longint", objfile);
- break;
- case FT_SIGNED_INTEGER:
- type = init_type (TYPE_CODE_INT,
- TARGET_INT_BIT / TARGET_CHAR_BIT,
- 0, "longint", objfile); /* FIXME -fnf */
- break;
- case FT_UNSIGNED_INTEGER:
- type = init_type (TYPE_CODE_INT,
- TARGET_INT_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "cardinal", objfile);
- break;
- case FT_LONG:
- type = init_type (TYPE_CODE_INT,
- TARGET_LONG_BIT / TARGET_CHAR_BIT,
- 0, "long", objfile);
- break;
- case FT_SIGNED_LONG:
- type = init_type (TYPE_CODE_INT,
- TARGET_LONG_BIT / TARGET_CHAR_BIT,
- 0, "long", objfile); /* FIXME -fnf */
- break;
- case FT_UNSIGNED_LONG:
- type = init_type (TYPE_CODE_INT,
- TARGET_LONG_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
- break;
- case FT_LONG_LONG:
- type = init_type (TYPE_CODE_INT,
- TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
- 0, "long long", objfile);
- break;
- case FT_SIGNED_LONG_LONG:
- type = init_type (TYPE_CODE_INT,
- TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
- 0, "signed long long", objfile);
- break;
- case FT_UNSIGNED_LONG_LONG:
- type = init_type (TYPE_CODE_INT,
- TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
- break;
- case FT_FLOAT:
- type = init_type (TYPE_CODE_FLT,
- TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
- 0, "float", objfile);
- break;
- case FT_DBL_PREC_FLOAT:
- type = init_type (TYPE_CODE_FLT,
- TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
- 0, "double", objfile);
- break;
- case FT_EXT_PREC_FLOAT:
- type = init_type (TYPE_CODE_FLT,
- TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
- 0, "extended", objfile);
- break;
- }
- return (type);
-}
-\f
-
-/* Table mapping opcodes into strings for printing operators
- and precedences of the operators. */
-
-const struct op_print pascal_op_print_tab[] =
-{
- {",", BINOP_COMMA, PREC_COMMA, 0},
- {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
- {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
- {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
- {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
- {"=", BINOP_EQUAL, PREC_EQUAL, 0},
- {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
- {"<=", BINOP_LEQ, PREC_ORDER, 0},
- {">=", BINOP_GEQ, PREC_ORDER, 0},
- {">", BINOP_GTR, PREC_ORDER, 0},
- {"<", BINOP_LESS, PREC_ORDER, 0},
- {"shr", BINOP_RSH, PREC_SHIFT, 0},
- {"shl", BINOP_LSH, PREC_SHIFT, 0},
- {"+", BINOP_ADD, PREC_ADD, 0},
- {"-", BINOP_SUB, PREC_ADD, 0},
- {"*", BINOP_MUL, PREC_MUL, 0},
- {"/", BINOP_DIV, PREC_MUL, 0},
- {"div", BINOP_INTDIV, PREC_MUL, 0},
- {"mod", BINOP_REM, PREC_MUL, 0},
- {"@", BINOP_REPEAT, PREC_REPEAT, 0},
- {"-", UNOP_NEG, PREC_PREFIX, 0},
- {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
- {"^", UNOP_IND, PREC_SUFFIX, 1},
- {"@", UNOP_ADDR, PREC_PREFIX, 0},
- {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
- {NULL, 0, 0, 0}
-};
-\f
-struct type **const /* CONST_PTR v 4.17 */ (pascal_builtin_types[]) =
-{
- &builtin_type_int,
- &builtin_type_long,
- &builtin_type_short,
- &builtin_type_char,
- &builtin_type_float,
- &builtin_type_double,
- &builtin_type_void,
- &builtin_type_long_long,
- &builtin_type_signed_char,
- &builtin_type_unsigned_char,
- &builtin_type_unsigned_short,
- &builtin_type_unsigned_int,
- &builtin_type_unsigned_long,
- &builtin_type_unsigned_long_long,
- &builtin_type_long_double,
- &builtin_type_complex,
- &builtin_type_double_complex,
- 0
-};
-
-const struct language_defn pascal_language_defn =
-{
- "pascal", /* Language name */
- language_pascal,
- pascal_builtin_types,
- range_check_on,
- type_check_on,
- case_sensitive_on,
- pascal_parse,
- pascal_error,
- evaluate_subexp_standard,
- pascal_printchar, /* Print a character constant */
- pascal_printstr, /* Function to print string constant */
- pascal_emit_char, /* Print a single char */
- pascal_create_fundamental_type, /* Create fundamental type in this language */
- pascal_print_type, /* Print a type using appropriate syntax */
- pascal_val_print, /* Print a value using appropriate syntax */
- pascal_value_print, /* Print a top-level value */
- {"", "%", "b", ""}, /* Binary format info */
- {"0%lo", "0", "o", ""}, /* Octal format info */
- {"%ld", "", "d", ""}, /* Decimal format info */
- {"$%lx", "$", "x", ""}, /* Hex format info */
- pascal_op_print_tab, /* expression operators for printing */
- 1, /* c-style arrays */
- 0, /* String lower bound */
- &builtin_type_char, /* Type of string elements */
- LANG_MAGIC
-};
-
-void
-_initialize_pascal_language (void)
-{
- add_language (&pascal_language_defn);
-}
+/* Pascal language support routines for GDB, the GNU debugger.\r
+ Copyright 2000 Free Software Foundation, Inc.\r
+\r
+ This file is part of GDB.\r
+\r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+\r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+\r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */\r
+\r
+/* This file is derived from c-lang.c */\r
+\r
+#include "defs.h"\r
+#include "symtab.h"\r
+#include "gdbtypes.h"\r
+#include "expression.h"\r
+#include "parser-defs.h"\r
+#include "language.h"\r
+#include "p-lang.h"\r
+#include "valprint.h"\r
+#include <ctype.h>\r
+ \r
+extern void _initialize_pascal_language (void);\r
+\r
+\r
+/* Determines if type TYPE is a pascal string type.\r
+ Returns 1 if the type is a known pascal type\r
+ This function is used by p-valprint.c code to allow better string display.\r
+ If it is a pascal string type, then it also sets info needed\r
+ to get the length and the data of the string\r
+ length_pos, length_size and string_pos are given in bytes.\r
+ char_size gives the element size in bytes.\r
+ FIXME: if the position or the size of these fields\r
+ are not multiple of TARGET_CHAR_BIT then the results are wrong\r
+ but this does not happen for Free Pascal nor for GPC. */\r
+int\r
+is_pascal_string_type (struct type *type,int *length_pos,\r
+ int * length_size, int *string_pos, int *char_size)\r
+{\r
+ if (TYPE_CODE (type) == TYPE_CODE_STRUCT)\r
+ {\r
+ /* Old Borland type pascal strings from Free Pascal Compiler. */\r
+ /* Two fields: length and st. */\r
+ if (TYPE_NFIELDS (type) == 2 \r
+ && strcmp (TYPE_FIELDS (type)[0].name, "length") == 0 \r
+ && strcmp (TYPE_FIELDS (type)[1].name, "st") == 0)\r
+ {\r
+ *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT;\r
+ *length_size = TYPE_FIELD_TYPE (type, 0)->length;\r
+ *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;\r
+ *char_size = 1;\r
+ return 1;\r
+ };\r
+ /* GNU pascal strings. */\r
+ /* Three fields: Capacity, length and schema$ or _p_schema. */\r
+ if (TYPE_NFIELDS (type) == 3\r
+ && strcmp (TYPE_FIELDS (type)[0].name, "Capacity") == 0\r
+ && strcmp (TYPE_FIELDS (type)[1].name, "length") == 0)\r
+ {\r
+ *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;\r
+ *length_size = TYPE_FIELD_TYPE (type, 1)->length;\r
+ *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT;\r
+ /* FIXME: how can I detect wide chars in GPC ?? */\r
+ *char_size = 1;\r
+ return 1;\r
+ };\r
+ }\r
+ return 0;\r
+}\r
+\r
+static void pascal_one_char (int, struct ui_file *, int *);\r
+\r
+/* Print the character C on STREAM as part of the contents of a literal\r
+ string.\r
+ In_quotes is reset to 0 if a char is written with #4 notation */\r
+\r
+static void\r
+pascal_one_char (register int c, struct ui_file *stream, int *in_quotes)\r
+{\r
+\r
+ c &= 0xFF; /* Avoid sign bit follies */\r
+\r
+ if ((c == '\'') || (PRINT_LITERAL_FORM (c)))\r
+ {\r
+ if (!(*in_quotes))\r
+ fputs_filtered ("'", stream);\r
+ *in_quotes = 1;\r
+ if (c == '\'')\r
+ {\r
+ fputs_filtered ("''", stream);\r
+ }\r
+ else\r
+ fprintf_filtered (stream, "%c", c);\r
+ }\r
+ else\r
+ {\r
+ if (*in_quotes)\r
+ fputs_filtered ("'", stream);\r
+ *in_quotes = 0;\r
+ fprintf_filtered (stream, "#%d", (unsigned int) c);\r
+ }\r
+}\r
+\r
+static void pascal_emit_char (int c, struct ui_file *stream, int quoter);\r
+\r
+/* Print the character C on STREAM as part of the contents of a literal\r
+ string whose delimiter is QUOTER. Note that that format for printing\r
+ characters and strings is language specific. */\r
+\r
+static void\r
+pascal_emit_char (register int c, struct ui_file *stream, int quoter)\r
+{\r
+ int in_quotes = 0;\r
+ pascal_one_char (c, stream, &in_quotes);\r
+ if (in_quotes)\r
+ fputs_filtered ("'", stream);\r
+}\r
+\r
+void\r
+pascal_printchar (int c, struct ui_file *stream)\r
+{\r
+ int in_quotes = 0;\r
+ pascal_one_char (c, stream, &in_quotes);\r
+ if (in_quotes)\r
+ fputs_filtered ("'", stream);\r
+}\r
+\r
+/* Print the character string STRING, printing at most LENGTH characters.\r
+ Printing stops early if the number hits print_max; repeat counts\r
+ are printed as appropriate. Print ellipses at the end if we\r
+ had to stop before printing LENGTH characters, or if FORCE_ELLIPSES. */\r
+\r
+void\r
+pascal_printstr (struct ui_file *stream, char *string, unsigned int length,\r
+ int width, int force_ellipses)\r
+{\r
+ register unsigned int i;\r
+ unsigned int things_printed = 0;\r
+ int in_quotes = 0;\r
+ int need_comma = 0;\r
+ extern int inspect_it;\r
+\r
+ /* If the string was not truncated due to `set print elements', and\r
+ the last byte of it is a null, we don't print that, in traditional C\r
+ style. */\r
+ if ((!force_ellipses) && length > 0 && string[length - 1] == '\0')\r
+ length--;\r
+\r
+ if (length == 0)\r
+ {\r
+ fputs_filtered ("''", stream);\r
+ return;\r
+ }\r
+\r
+ for (i = 0; i < length && things_printed < print_max; ++i)\r
+ {\r
+ /* Position of the character we are examining\r
+ to see whether it is repeated. */\r
+ unsigned int rep1;\r
+ /* Number of repetitions we have detected so far. */\r
+ unsigned int reps;\r
+\r
+ QUIT;\r
+\r
+ if (need_comma)\r
+ {\r
+ fputs_filtered (", ", stream);\r
+ need_comma = 0;\r
+ }\r
+\r
+ rep1 = i + 1;\r
+ reps = 1;\r
+ while (rep1 < length && string[rep1] == string[i])\r
+ {\r
+ ++rep1;\r
+ ++reps;\r
+ }\r
+\r
+ if (reps > repeat_count_threshold)\r
+ {\r
+ if (in_quotes)\r
+ {\r
+ if (inspect_it)\r
+ fputs_filtered ("\\', ", stream);\r
+ else\r
+ fputs_filtered ("', ", stream);\r
+ in_quotes = 0;\r
+ }\r
+ pascal_printchar (string[i], stream);\r
+ fprintf_filtered (stream, " <repeats %u times>", reps);\r
+ i = rep1 - 1;\r
+ things_printed += repeat_count_threshold;\r
+ need_comma = 1;\r
+ }\r
+ else\r
+ {\r
+ int c = string[i];\r
+ if ((!in_quotes) && (PRINT_LITERAL_FORM (c)))\r
+ {\r
+ if (inspect_it)\r
+ fputs_filtered ("\\'", stream);\r
+ else\r
+ fputs_filtered ("'", stream);\r
+ in_quotes = 1;\r
+ }\r
+ pascal_one_char (c, stream, &in_quotes);\r
+ ++things_printed;\r
+ }\r
+ }\r
+\r
+ /* Terminate the quotes if necessary. */\r
+ if (in_quotes)\r
+ {\r
+ if (inspect_it)\r
+ fputs_filtered ("\\'", stream);\r
+ else\r
+ fputs_filtered ("'", stream);\r
+ }\r
+\r
+ if (force_ellipses || i < length)\r
+ fputs_filtered ("...", stream);\r
+}\r
+\r
+/* Create a fundamental Pascal type using default reasonable for the current\r
+ target machine.\r
+\r
+ Some object/debugging file formats (DWARF version 1, COFF, etc) do not\r
+ define fundamental types such as "int" or "double". Others (stabs or\r
+ DWARF version 2, etc) do define fundamental types. For the formats which\r
+ don't provide fundamental types, gdb can create such types using this\r
+ function.\r
+\r
+ FIXME: Some compilers distinguish explicitly signed integral types\r
+ (signed short, signed int, signed long) from "regular" integral types\r
+ (short, int, long) in the debugging information. There is some dis-\r
+ agreement as to how useful this feature is. In particular, gcc does\r
+ not support this. Also, only some debugging formats allow the\r
+ distinction to be passed on to a debugger. For now, we always just\r
+ use "short", "int", or "long" as the type name, for both the implicit\r
+ and explicitly signed types. This also makes life easier for the\r
+ gdb test suite since we don't have to account for the differences\r
+ in output depending upon what the compiler and debugging format\r
+ support. We will probably have to re-examine the issue when gdb\r
+ starts taking it's fundamental type information directly from the\r
+ debugging information supplied by the compiler. fnf@cygnus.com */\r
+\r
+/* Note there might be some discussion about the choosen correspondance\r
+ because it mainly reflects Free Pascal Compiler setup for now PM */\r
+\r
+\r
+struct type *\r
+pascal_create_fundamental_type (struct objfile *objfile, int typeid)\r
+{\r
+ register struct type *type = NULL;\r
+\r
+ switch (typeid)\r
+ {\r
+ default:\r
+ /* FIXME: For now, if we are asked to produce a type not in this\r
+ language, create the equivalent of a C integer type with the\r
+ name "<?type?>". When all the dust settles from the type\r
+ reconstruction work, this should probably become an error. */\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_INT_BIT / TARGET_CHAR_BIT,\r
+ 0, "<?type?>", objfile);\r
+ warning ("internal error: no Pascal fundamental type %d", typeid);\r
+ break;\r
+ case FT_VOID:\r
+ type = init_type (TYPE_CODE_VOID,\r
+ TARGET_CHAR_BIT / TARGET_CHAR_BIT,\r
+ 0, "void", objfile);\r
+ break;\r
+ case FT_CHAR:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_CHAR_BIT / TARGET_CHAR_BIT,\r
+ 0, "char", objfile);\r
+ break;\r
+ case FT_SIGNED_CHAR:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_CHAR_BIT / TARGET_CHAR_BIT,\r
+ 0, "shortint", objfile);\r
+ break;\r
+ case FT_UNSIGNED_CHAR:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_CHAR_BIT / TARGET_CHAR_BIT,\r
+ TYPE_FLAG_UNSIGNED, "byte", objfile);\r
+ break;\r
+ case FT_SHORT:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_SHORT_BIT / TARGET_CHAR_BIT,\r
+ 0, "integer", objfile);\r
+ break;\r
+ case FT_SIGNED_SHORT:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_SHORT_BIT / TARGET_CHAR_BIT,\r
+ 0, "integer", objfile); /* FIXME-fnf */\r
+ break;\r
+ case FT_UNSIGNED_SHORT:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_SHORT_BIT / TARGET_CHAR_BIT,\r
+ TYPE_FLAG_UNSIGNED, "word", objfile);\r
+ break;\r
+ case FT_INTEGER:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_INT_BIT / TARGET_CHAR_BIT,\r
+ 0, "longint", objfile);\r
+ break;\r
+ case FT_SIGNED_INTEGER:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_INT_BIT / TARGET_CHAR_BIT,\r
+ 0, "longint", objfile); /* FIXME -fnf */\r
+ break;\r
+ case FT_UNSIGNED_INTEGER:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_INT_BIT / TARGET_CHAR_BIT,\r
+ TYPE_FLAG_UNSIGNED, "cardinal", objfile);\r
+ break;\r
+ case FT_LONG:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_LONG_BIT / TARGET_CHAR_BIT,\r
+ 0, "long", objfile);\r
+ break;\r
+ case FT_SIGNED_LONG:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_LONG_BIT / TARGET_CHAR_BIT,\r
+ 0, "long", objfile); /* FIXME -fnf */\r
+ break;\r
+ case FT_UNSIGNED_LONG:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_LONG_BIT / TARGET_CHAR_BIT,\r
+ TYPE_FLAG_UNSIGNED, "unsigned long", objfile);\r
+ break;\r
+ case FT_LONG_LONG:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,\r
+ 0, "long long", objfile);\r
+ break;\r
+ case FT_SIGNED_LONG_LONG:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,\r
+ 0, "signed long long", objfile);\r
+ break;\r
+ case FT_UNSIGNED_LONG_LONG:\r
+ type = init_type (TYPE_CODE_INT,\r
+ TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,\r
+ TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);\r
+ break;\r
+ case FT_FLOAT:\r
+ type = init_type (TYPE_CODE_FLT,\r
+ TARGET_FLOAT_BIT / TARGET_CHAR_BIT,\r
+ 0, "float", objfile);\r
+ break;\r
+ case FT_DBL_PREC_FLOAT:\r
+ type = init_type (TYPE_CODE_FLT,\r
+ TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,\r
+ 0, "double", objfile);\r
+ break;\r
+ case FT_EXT_PREC_FLOAT:\r
+ type = init_type (TYPE_CODE_FLT,\r
+ TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,\r
+ 0, "extended", objfile);\r
+ break;\r
+ }\r
+ return (type);\r
+}\r
+\f\r
+\r
+/* Table mapping opcodes into strings for printing operators\r
+ and precedences of the operators. */\r
+\r
+const struct op_print pascal_op_print_tab[] =\r
+{\r
+ {",", BINOP_COMMA, PREC_COMMA, 0},\r
+ {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},\r
+ {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},\r
+ {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},\r
+ {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},\r
+ {"=", BINOP_EQUAL, PREC_EQUAL, 0},\r
+ {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},\r
+ {"<=", BINOP_LEQ, PREC_ORDER, 0},\r
+ {">=", BINOP_GEQ, PREC_ORDER, 0},\r
+ {">", BINOP_GTR, PREC_ORDER, 0},\r
+ {"<", BINOP_LESS, PREC_ORDER, 0},\r
+ {"shr", BINOP_RSH, PREC_SHIFT, 0},\r
+ {"shl", BINOP_LSH, PREC_SHIFT, 0},\r
+ {"+", BINOP_ADD, PREC_ADD, 0},\r
+ {"-", BINOP_SUB, PREC_ADD, 0},\r
+ {"*", BINOP_MUL, PREC_MUL, 0},\r
+ {"/", BINOP_DIV, PREC_MUL, 0},\r
+ {"div", BINOP_INTDIV, PREC_MUL, 0},\r
+ {"mod", BINOP_REM, PREC_MUL, 0},\r
+ {"@", BINOP_REPEAT, PREC_REPEAT, 0},\r
+ {"-", UNOP_NEG, PREC_PREFIX, 0},\r
+ {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},\r
+ {"^", UNOP_IND, PREC_SUFFIX, 1},\r
+ {"@", UNOP_ADDR, PREC_PREFIX, 0},\r
+ {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},\r
+ {NULL, 0, 0, 0}\r
+};\r
+\f\r
+struct type **const /* CONST_PTR v 4.17 */ (pascal_builtin_types[]) =\r
+{\r
+ &builtin_type_int,\r
+ &builtin_type_long,\r
+ &builtin_type_short,\r
+ &builtin_type_char,\r
+ &builtin_type_float,\r
+ &builtin_type_double,\r
+ &builtin_type_void,\r
+ &builtin_type_long_long,\r
+ &builtin_type_signed_char,\r
+ &builtin_type_unsigned_char,\r
+ &builtin_type_unsigned_short,\r
+ &builtin_type_unsigned_int,\r
+ &builtin_type_unsigned_long,\r
+ &builtin_type_unsigned_long_long,\r
+ &builtin_type_long_double,\r
+ &builtin_type_complex,\r
+ &builtin_type_double_complex,\r
+ 0\r
+};\r
+\r
+const struct language_defn pascal_language_defn =\r
+{\r
+ "pascal", /* Language name */\r
+ language_pascal,\r
+ pascal_builtin_types,\r
+ range_check_on,\r
+ type_check_on,\r
+ case_sensitive_on,\r
+ pascal_parse,\r
+ pascal_error,\r
+ evaluate_subexp_standard,\r
+ pascal_printchar, /* Print a character constant */\r
+ pascal_printstr, /* Function to print string constant */\r
+ pascal_emit_char, /* Print a single char */\r
+ pascal_create_fundamental_type, /* Create fundamental type in this language */\r
+ pascal_print_type, /* Print a type using appropriate syntax */\r
+ pascal_val_print, /* Print a value using appropriate syntax */\r
+ pascal_value_print, /* Print a top-level value */\r
+ {"", "%", "b", ""}, /* Binary format info */\r
+ {"0%lo", "0", "o", ""}, /* Octal format info */\r
+ {"%ld", "", "d", ""}, /* Decimal format info */\r
+ {"$%lx", "$", "x", ""}, /* Hex format info */\r
+ pascal_op_print_tab, /* expression operators for printing */\r
+ 1, /* c-style arrays */\r
+ 0, /* String lower bound */\r
+ &builtin_type_char, /* Type of string elements */\r
+ LANG_MAGIC\r
+};\r
+\r
+void\r
+_initialize_pascal_language (void)\r
+{\r
+ add_language (&pascal_language_defn);\r
+}\r
-/* Support for printing Pascal values for GDB, the GNU debugger.
- Copyright 2000
- Free Software Foundation, Inc.
-
- 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 2 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, write to the Free Software
- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
-
-/* This file is derived from c-valprint.c */
-
-#include "defs.h"
-#include "obstack.h"
-#include "symtab.h"
-#include "gdbtypes.h"
-#include "expression.h"
-#include "value.h"
-#include "command.h"
-#include "gdbcmd.h"
-#include "gdbcore.h"
-#include "demangle.h"
-#include "valprint.h"
-#include "typeprint.h"
-#include "language.h"
-#include "target.h"
-#include "annotate.h"
-#include "p-lang.h"
-\f
-
-
-
-/* Print data of type TYPE located at VALADDR (within GDB), which came from
- the inferior at address ADDRESS, onto stdio stream STREAM according to
- FORMAT (a letter or 0 for natural format). The data at VALADDR is in
- target byte order.
-
- If the data are a string pointer, returns the number of string characters
- printed.
-
- If DEREF_REF is nonzero, then dereference references, otherwise just print
- them like pointers.
-
- The PRETTY parameter controls prettyprinting. */
-
-
-int
-pascal_val_print (struct type *type, char *valaddr, int embedded_offset,
- CORE_ADDR address, struct ui_file *stream, int format,
- int deref_ref, int recurse, enum val_prettyprint pretty)
-{
- register unsigned int i = 0; /* Number of characters printed */
- unsigned len;
- struct type *elttype;
- unsigned eltlen;
- LONGEST val;
- CORE_ADDR addr;
-
- CHECK_TYPEDEF (type);
- switch (TYPE_CODE (type))
- {
- case TYPE_CODE_ARRAY:
- if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
- {
- elttype = check_typedef (TYPE_TARGET_TYPE (type));
- eltlen = TYPE_LENGTH (elttype);
- len = TYPE_LENGTH (type) / eltlen;
- if (prettyprint_arrays)
- {
- print_spaces_filtered (2 + 2 * recurse, stream);
- }
- /* For an array of chars, print with string syntax. */
- if (eltlen == 1 &&
- ((TYPE_CODE (elttype) == TYPE_CODE_INT)
- || ((current_language->la_language == language_m2)
- && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
- && (format == 0 || format == 's'))
- {
- /* If requested, look for the first null char and only print
- elements up to it. */
- if (stop_print_at_null)
- {
- unsigned int temp_len;
-
- /* Look for a NULL char. */
- for (temp_len = 0;
- (valaddr + embedded_offset)[temp_len]
- && temp_len < len && temp_len < print_max;
- temp_len++);
- len = temp_len;
- }
-
- LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);
- i = len;
- }
- else
- {
- fprintf_filtered (stream, "{");
- /* If this is a virtual function table, print the 0th
- entry specially, and the rest of the members normally. */
- if (pascal_object_is_vtbl_ptr_type (elttype))
- {
- i = 1;
- fprintf_filtered (stream, "%d vtable entries", len - 1);
- }
- else
- {
- i = 0;
- }
- val_print_array_elements (type, valaddr + embedded_offset, address, stream,
- format, deref_ref, recurse, pretty, i);
- fprintf_filtered (stream, "}");
- }
- break;
- }
- /* Array of unspecified length: treat like pointer to first elt. */
- addr = address;
- goto print_unpacked_pointer;
-
- case TYPE_CODE_PTR:
- if (format && format != 's')
- {
- print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
- break;
- }
- if (vtblprint && pascal_object_is_vtbl_ptr_type (type))
- {
- /* Print the unmangled name if desired. */
- /* Print vtable entry - we only get here if we ARE using
- -fvtable_thunks. (Otherwise, look under TYPE_CODE_STRUCT.) */
- print_address_demangle (extract_address (valaddr + embedded_offset, TYPE_LENGTH (type)),
- stream, demangle);
- break;
- }
- elttype = check_typedef (TYPE_TARGET_TYPE (type));
- if (TYPE_CODE (elttype) == TYPE_CODE_METHOD)
- {
- pascal_object_print_class_method (valaddr + embedded_offset, type, stream);
- }
- else if (TYPE_CODE (elttype) == TYPE_CODE_MEMBER)
- {
- pascal_object_print_class_member (valaddr + embedded_offset,
- TYPE_DOMAIN_TYPE (TYPE_TARGET_TYPE (type)),
- stream, "&");
- }
- else
- {
- addr = unpack_pointer (type, valaddr + embedded_offset);
- print_unpacked_pointer:
- elttype = check_typedef (TYPE_TARGET_TYPE (type));
-
- if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
- {
- /* Try to print what function it points to. */
- print_address_demangle (addr, stream, demangle);
- /* Return value is irrelevant except for string pointers. */
- return (0);
- }
-
- if (addressprint && format != 's')
- {
- print_address_numeric (addr, 1, stream);
- }
-
- /* For a pointer to char or unsigned char, also print the string
- pointed to, unless pointer is null. */
- if (TYPE_LENGTH (elttype) == 1
- && TYPE_CODE (elttype) == TYPE_CODE_INT
- && (format == 0 || format == 's')
- && addr != 0)
- {
- /* no wide string yet */
- i = val_print_string (addr, -1, 1, stream);
- }
- /* also for pointers to pascal strings */
- /* Note: this is Free Pascal specific:
- as GDB does not recognize stabs pascal strings
- Pascal strings are mapped to records
- with lowercase names PM */
- /* I don't know what GPC does :( PM */
- if (TYPE_CODE (elttype) == TYPE_CODE_STRUCT &&
- TYPE_NFIELDS (elttype) == 2 &&
- strcmp (TYPE_FIELDS (elttype)[0].name, "length") == 0 &&
- strcmp (TYPE_FIELDS (elttype)[1].name, "st") == 0 &&
- addr != 0)
- {
- char bytelength;
- read_memory (addr, &bytelength, 1);
- i = val_print_string (addr + 1, bytelength, 1, stream);
- }
- else if (pascal_object_is_vtbl_member (type))
- {
- /* print vtbl's nicely */
- CORE_ADDR vt_address = unpack_pointer (type, valaddr + embedded_offset);
-
- struct minimal_symbol *msymbol =
- lookup_minimal_symbol_by_pc (vt_address);
- if ((msymbol != NULL) &&
- (vt_address == SYMBOL_VALUE_ADDRESS (msymbol)))
- {
- fputs_filtered (" <", stream);
- fputs_filtered (SYMBOL_SOURCE_NAME (msymbol), stream);
- fputs_filtered (">", stream);
- }
- if (vt_address && vtblprint)
- {
- value_ptr vt_val;
- struct symbol *wsym = (struct symbol *) NULL;
- struct type *wtype;
- struct symtab *s;
- struct block *block = (struct block *) NULL;
- int is_this_fld;
-
- if (msymbol != NULL)
- wsym = lookup_symbol (SYMBOL_NAME (msymbol), block,
- VAR_NAMESPACE, &is_this_fld, &s);
-
- if (wsym)
- {
- wtype = SYMBOL_TYPE (wsym);
- }
- else
- {
- wtype = TYPE_TARGET_TYPE (type);
- }
- vt_val = value_at (wtype, vt_address, NULL);
- val_print (VALUE_TYPE (vt_val), VALUE_CONTENTS (vt_val), 0,
- VALUE_ADDRESS (vt_val), stream, format,
- deref_ref, recurse + 1, pretty);
- if (pretty)
- {
- fprintf_filtered (stream, "\n");
- print_spaces_filtered (2 + 2 * recurse, stream);
- }
- }
- }
-
- /* Return number of characters printed, including the terminating
- '\0' if we reached the end. val_print_string takes care including
- the terminating '\0' if necessary. */
- return i;
- }
- break;
-
- case TYPE_CODE_MEMBER:
- error ("not implemented: member type in pascal_val_print");
- break;
-
- case TYPE_CODE_REF:
- elttype = check_typedef (TYPE_TARGET_TYPE (type));
- if (TYPE_CODE (elttype) == TYPE_CODE_MEMBER)
- {
- pascal_object_print_class_member (valaddr + embedded_offset,
- TYPE_DOMAIN_TYPE (elttype),
- stream, "");
- break;
- }
- if (addressprint)
- {
- fprintf_filtered (stream, "@");
- print_address_numeric
- (extract_address (valaddr + embedded_offset,
- TARGET_PTR_BIT / HOST_CHAR_BIT), 1, stream);
- if (deref_ref)
- fputs_filtered (": ", stream);
- }
- /* De-reference the reference. */
- if (deref_ref)
- {
- if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
- {
- value_ptr deref_val =
- value_at
- (TYPE_TARGET_TYPE (type),
- unpack_pointer (lookup_pointer_type (builtin_type_void),
- valaddr + embedded_offset),
- NULL);
- val_print (VALUE_TYPE (deref_val),
- VALUE_CONTENTS (deref_val), 0,
- VALUE_ADDRESS (deref_val), stream, format,
- deref_ref, recurse + 1, pretty);
- }
- else
- fputs_filtered ("???", stream);
- }
- break;
-
- case TYPE_CODE_UNION:
- if (recurse && !unionprint)
- {
- fprintf_filtered (stream, "{...}");
- break;
- }
- /* Fall through. */
- case TYPE_CODE_STRUCT:
- if (vtblprint && pascal_object_is_vtbl_ptr_type (type))
- {
- /* Print the unmangled name if desired. */
- /* Print vtable entry - we only get here if NOT using
- -fvtable_thunks. (Otherwise, look under TYPE_CODE_PTR.) */
- print_address_demangle (extract_address (
- valaddr + embedded_offset + TYPE_FIELD_BITPOS (type, VTBL_FNADDR_OFFSET) / 8,
- TYPE_LENGTH (TYPE_FIELD_TYPE (type, VTBL_FNADDR_OFFSET))),
- stream, demangle);
- }
- else
- {
- if ((TYPE_NFIELDS (type) == 2) &&
- (strcmp (TYPE_FIELDS (type)[0].name, "length") == 0) &&
- (strcmp (TYPE_FIELDS (type)[1].name, "st") == 0))
- {
- len = (*(valaddr + embedded_offset)) & 0xff;
- LA_PRINT_STRING (stream, valaddr + embedded_offset + 1, len, /* width ?? */ 0, 0);
- }
- else
- pascal_object_print_value_fields (type, valaddr + embedded_offset, address, stream, format,
- recurse, pretty, NULL, 0);
- }
- break;
-
- case TYPE_CODE_ENUM:
- if (format)
- {
- print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
- break;
- }
- len = TYPE_NFIELDS (type);
- val = unpack_long (type, valaddr + embedded_offset);
- for (i = 0; i < len; i++)
- {
- QUIT;
- if (val == TYPE_FIELD_BITPOS (type, i))
- {
- break;
- }
- }
- if (i < len)
- {
- fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
- }
- else
- {
- print_longest (stream, 'd', 0, val);
- }
- break;
-
- case TYPE_CODE_FUNC:
- if (format)
- {
- print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
- break;
- }
- /* FIXME, we should consider, at least for ANSI C language, eliminating
- the distinction made between FUNCs and POINTERs to FUNCs. */
- fprintf_filtered (stream, "{");
- type_print (type, "", stream, -1);
- fprintf_filtered (stream, "} ");
- /* Try to print what function it points to, and its address. */
- print_address_demangle (address, stream, demangle);
- break;
-
- case TYPE_CODE_BOOL:
- format = format ? format : output_format;
- if (format)
- print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
- else
- {
- val = unpack_long (type, valaddr + embedded_offset);
- if (val == 0)
- fputs_filtered ("false", stream);
- else if (val == 1)
- fputs_filtered ("true", stream);
- else
- {
- fputs_filtered ("true (", stream);
- fprintf_filtered (stream, "%ld)", (long int) val);
- }
- }
- break;
-
- case TYPE_CODE_RANGE:
- /* FIXME: create_range_type does not set the unsigned bit in a
- range type (I think it probably should copy it from the target
- type), so we won't print values which are too large to
- fit in a signed integer correctly. */
- /* FIXME: Doesn't handle ranges of enums correctly. (Can't just
- print with the target type, though, because the size of our type
- and the target type might differ). */
- /* FALLTHROUGH */
-
- case TYPE_CODE_INT:
- format = format ? format : output_format;
- if (format)
- {
- print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
- }
- else
- {
- val_print_type_code_int (type, valaddr + embedded_offset, stream);
- }
- break;
-
- case TYPE_CODE_CHAR:
- format = format ? format : output_format;
- if (format)
- {
- print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
- }
- else
- {
- val = unpack_long (type, valaddr + embedded_offset);
- if (TYPE_UNSIGNED (type))
- fprintf_filtered (stream, "%u", (unsigned int) val);
- else
- fprintf_filtered (stream, "%d", (int) val);
- fputs_filtered (" ", stream);
- LA_PRINT_CHAR ((unsigned char) val, stream);
- }
- break;
-
- case TYPE_CODE_FLT:
- if (format)
- {
- print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
- }
- else
- {
- print_floating (valaddr + embedded_offset, type, stream);
- }
- break;
-
- case TYPE_CODE_BITSTRING:
- case TYPE_CODE_SET:
- elttype = TYPE_INDEX_TYPE (type);
- CHECK_TYPEDEF (elttype);
- if (TYPE_FLAGS (elttype) & TYPE_FLAG_STUB)
- {
- fprintf_filtered (stream, "<incomplete type>");
- gdb_flush (stream);
- break;
- }
- else
- {
- struct type *range = elttype;
- LONGEST low_bound, high_bound;
- int i;
- int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
- int need_comma = 0;
-
- if (is_bitstring)
- fputs_filtered ("B'", stream);
- else
- fputs_filtered ("[", stream);
-
- i = get_discrete_bounds (range, &low_bound, &high_bound);
- maybe_bad_bstring:
- if (i < 0)
- {
- fputs_filtered ("<error value>", stream);
- goto done;
- }
-
- for (i = low_bound; i <= high_bound; i++)
- {
- int element = value_bit_index (type, valaddr + embedded_offset, i);
- if (element < 0)
- {
- i = element;
- goto maybe_bad_bstring;
- }
- if (is_bitstring)
- fprintf_filtered (stream, "%d", element);
- else if (element)
- {
- if (need_comma)
- fputs_filtered (", ", stream);
- print_type_scalar (range, i, stream);
- need_comma = 1;
-
- if (i + 1 <= high_bound && value_bit_index (type, valaddr + embedded_offset, ++i))
- {
- int j = i;
- fputs_filtered ("..", stream);
- while (i + 1 <= high_bound
- && value_bit_index (type, valaddr + embedded_offset, ++i))
- j = i;
- print_type_scalar (range, j, stream);
- }
- }
- }
- done:
- if (is_bitstring)
- fputs_filtered ("'", stream);
- else
- fputs_filtered ("]", stream);
- }
- break;
-
- case TYPE_CODE_VOID:
- fprintf_filtered (stream, "void");
- break;
-
- case TYPE_CODE_ERROR:
- fprintf_filtered (stream, "<error type>");
- break;
-
- case TYPE_CODE_UNDEF:
- /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
- dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
- and no complete type for struct foo in that file. */
- fprintf_filtered (stream, "<incomplete type>");
- break;
-
- default:
- error ("Invalid pascal type code %d in symbol table.", TYPE_CODE (type));
- }
- gdb_flush (stream);
- return (0);
-}
-\f
-int
-pascal_value_print (value_ptr val, struct ui_file *stream, int format,
- enum val_prettyprint pretty)
-{
- struct type *type = VALUE_TYPE (val);
-
- /* If it is a pointer, indicate what it points to.
-
- Print type also if it is a reference.
-
- Object pascal: if it is a member pointer, we will take care
- of that when we print it. */
- if (TYPE_CODE (type) == TYPE_CODE_PTR ||
- TYPE_CODE (type) == TYPE_CODE_REF)
- {
- /* Hack: remove (char *) for char strings. Their
- type is indicated by the quoted string anyway. */
- if (TYPE_CODE (type) == TYPE_CODE_PTR &&
- TYPE_NAME (type) == NULL &&
- TYPE_NAME (TYPE_TARGET_TYPE (type)) != NULL &&
- STREQ (TYPE_NAME (TYPE_TARGET_TYPE (type)), "char"))
- {
- /* Print nothing */
- }
- else
- {
- fprintf_filtered (stream, "(");
- type_print (type, "", stream, -1);
- fprintf_filtered (stream, ") ");
- }
- }
- return val_print (type, VALUE_CONTENTS (val), VALUE_EMBEDDED_OFFSET (val),
- VALUE_ADDRESS (val) + VALUE_OFFSET (val),
- stream, format, 1, 0, pretty);
-}
-
-
-/******************************************************************************
- Inserted from cp-valprint
-******************************************************************************/
-
-extern int vtblprint; /* Controls printing of vtbl's */
-extern int objectprint; /* Controls looking up an object's derived type
- using what we find in its vtables. */
-static int pascal_static_field_print; /* Controls printing of static fields. */
-
-static struct obstack dont_print_vb_obstack;
-static struct obstack dont_print_statmem_obstack;
-
-static void
- pascal_object_print_static_field (struct type *, value_ptr, struct ui_file *, int, int,
- enum val_prettyprint);
-
-static void
- pascal_object_print_value (struct type *, char *, CORE_ADDR, struct ui_file *,
- int, int, enum val_prettyprint, struct type **);
-
-void
-pascal_object_print_class_method (char *valaddr, struct type *type,
- struct ui_file *stream)
-{
- struct type *domain;
- struct fn_field *f = NULL;
- int j = 0;
- int len2;
- int offset;
- char *kind = "";
- CORE_ADDR addr;
- struct symbol *sym;
- unsigned len;
- unsigned int i;
- struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
-
- domain = TYPE_DOMAIN_TYPE (target_type);
- if (domain == (struct type *) NULL)
- {
- fprintf_filtered (stream, "<unknown>");
- return;
- }
- addr = unpack_pointer (lookup_pointer_type (builtin_type_void), valaddr);
- if (METHOD_PTR_IS_VIRTUAL (addr))
- {
- offset = METHOD_PTR_TO_VOFFSET (addr);
- len = TYPE_NFN_FIELDS (domain);
- for (i = 0; i < len; i++)
- {
- f = TYPE_FN_FIELDLIST1 (domain, i);
- len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
-
- for (j = 0; j < len2; j++)
- {
- QUIT;
- if (TYPE_FN_FIELD_VOFFSET (f, j) == offset)
- {
- if (TYPE_FN_FIELD_STUB (f, j))
- check_stub_method (domain, i, j);
- kind = "virtual ";
- goto common;
- }
- }
- }
- }
- else
- {
- sym = find_pc_function (addr);
- if (sym == 0)
- {
- error ("invalid pointer to member function");
- }
- len = TYPE_NFN_FIELDS (domain);
- for (i = 0; i < len; i++)
- {
- f = TYPE_FN_FIELDLIST1 (domain, i);
- len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
-
- for (j = 0; j < len2; j++)
- {
- QUIT;
- if (TYPE_FN_FIELD_STUB (f, j))
- check_stub_method (domain, i, j);
- if (STREQ (SYMBOL_NAME (sym), TYPE_FN_FIELD_PHYSNAME (f, j)))
- {
- goto common;
- }
- }
- }
- }
-common:
- if (i < len)
- {
- char *demangled_name;
-
- fprintf_filtered (stream, "&");
- fprintf_filtered (stream, kind);
- demangled_name = cplus_demangle (TYPE_FN_FIELD_PHYSNAME (f, j),
- DMGL_ANSI | DMGL_PARAMS);
- if (demangled_name == NULL)
- fprintf_filtered (stream, "<badly mangled name %s>",
- TYPE_FN_FIELD_PHYSNAME (f, j));
- else
- {
- fputs_filtered (demangled_name, stream);
- xfree (demangled_name);
- }
- }
- else
- {
- fprintf_filtered (stream, "(");
- type_print (type, "", stream, -1);
- fprintf_filtered (stream, ") %d", (int) addr >> 3);
- }
-}
-
-/* It was changed to this after 2.4.5. */
-const char pascal_vtbl_ptr_name[] =
-{'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
-
-/* Return truth value for assertion that TYPE is of the type
- "pointer to virtual function". */
-
-int
-pascal_object_is_vtbl_ptr_type (struct type *type)
-{
- char *typename = type_name_no_tag (type);
-
- return (typename != NULL
- && (STREQ (typename, pascal_vtbl_ptr_name)));
-}
-
-/* Return truth value for the assertion that TYPE is of the type
- "pointer to virtual function table". */
-
-int
-pascal_object_is_vtbl_member (struct type *type)
-{
- if (TYPE_CODE (type) == TYPE_CODE_PTR)
- {
- type = TYPE_TARGET_TYPE (type);
- if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
- {
- type = TYPE_TARGET_TYPE (type);
- if (TYPE_CODE (type) == TYPE_CODE_STRUCT /* if not using thunks */
- || TYPE_CODE (type) == TYPE_CODE_PTR) /* if using thunks */
- {
- /* Virtual functions tables are full of pointers
- to virtual functions. */
- return pascal_object_is_vtbl_ptr_type (type);
- }
- }
- }
- return 0;
-}
-
-/* Mutually recursive subroutines of pascal_object_print_value and c_val_print to
- print out a structure's fields: pascal_object_print_value_fields and pascal_object_print_value.
-
- TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and PRETTY have the
- same meanings as in pascal_object_print_value and c_val_print.
-
- DONT_PRINT is an array of baseclass types that we
- should not print, or zero if called from top level. */
-
-void
-pascal_object_print_value_fields (struct type *type, char *valaddr,
- CORE_ADDR address, struct ui_file *stream,
- int format, int recurse,
- enum val_prettyprint pretty,
- struct type **dont_print_vb,
- int dont_print_statmem)
-{
- int i, len, n_baseclasses;
- struct obstack tmp_obstack;
- char *last_dont_print = obstack_next_free (&dont_print_statmem_obstack);
-
- CHECK_TYPEDEF (type);
-
- fprintf_filtered (stream, "{");
- len = TYPE_NFIELDS (type);
- n_baseclasses = TYPE_N_BASECLASSES (type);
-
- /* Print out baseclasses such that we don't print
- duplicates of virtual baseclasses. */
- if (n_baseclasses > 0)
- pascal_object_print_value (type, valaddr, address, stream,
- format, recurse + 1, pretty, dont_print_vb);
-
- if (!len && n_baseclasses == 1)
- fprintf_filtered (stream, "<No data fields>");
- else
- {
- extern int inspect_it;
- int fields_seen = 0;
-
- if (dont_print_statmem == 0)
- {
- /* If we're at top level, carve out a completely fresh
- chunk of the obstack and use that until this particular
- invocation returns. */
- tmp_obstack = dont_print_statmem_obstack;
- obstack_finish (&dont_print_statmem_obstack);
- }
-
- for (i = n_baseclasses; i < len; i++)
- {
- /* If requested, skip printing of static fields. */
- if (!pascal_static_field_print && TYPE_FIELD_STATIC (type, i))
- continue;
- if (fields_seen)
- fprintf_filtered (stream, ", ");
- else if (n_baseclasses > 0)
- {
- if (pretty)
- {
- fprintf_filtered (stream, "\n");
- print_spaces_filtered (2 + 2 * recurse, stream);
- fputs_filtered ("members of ", stream);
- fputs_filtered (type_name_no_tag (type), stream);
- fputs_filtered (": ", stream);
- }
- }
- fields_seen = 1;
-
- if (pretty)
- {
- fprintf_filtered (stream, "\n");
- print_spaces_filtered (2 + 2 * recurse, stream);
- }
- else
- {
- wrap_here (n_spaces (2 + 2 * recurse));
- }
- if (inspect_it)
- {
- if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) == TYPE_CODE_PTR)
- fputs_filtered ("\"( ptr \"", stream);
- else
- fputs_filtered ("\"( nodef \"", stream);
- if (TYPE_FIELD_STATIC (type, i))
- fputs_filtered ("static ", stream);
- fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
- language_cplus,
- DMGL_PARAMS | DMGL_ANSI);
- fputs_filtered ("\" \"", stream);
- fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
- language_cplus,
- DMGL_PARAMS | DMGL_ANSI);
- fputs_filtered ("\") \"", stream);
- }
- else
- {
- annotate_field_begin (TYPE_FIELD_TYPE (type, i));
-
- if (TYPE_FIELD_STATIC (type, i))
- fputs_filtered ("static ", stream);
- fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
- language_cplus,
- DMGL_PARAMS | DMGL_ANSI);
- annotate_field_name_end ();
- fputs_filtered (" = ", stream);
- annotate_field_value ();
- }
-
- if (!TYPE_FIELD_STATIC (type, i) && TYPE_FIELD_PACKED (type, i))
- {
- value_ptr v;
-
- /* Bitfields require special handling, especially due to byte
- order problems. */
- if (TYPE_FIELD_IGNORE (type, i))
- {
- fputs_filtered ("<optimized out or zero length>", stream);
- }
- else
- {
- v = value_from_longest (TYPE_FIELD_TYPE (type, i),
- unpack_field_as_long (type, valaddr, i));
-
- val_print (TYPE_FIELD_TYPE (type, i), VALUE_CONTENTS (v), 0, 0,
- stream, format, 0, recurse + 1, pretty);
- }
- }
- else
- {
- if (TYPE_FIELD_IGNORE (type, i))
- {
- fputs_filtered ("<optimized out or zero length>", stream);
- }
- else if (TYPE_FIELD_STATIC (type, i))
- {
- /* value_ptr v = value_static_field (type, i); v4.17 specific */
- value_ptr v;
- v = value_from_longest (TYPE_FIELD_TYPE (type, i),
- unpack_field_as_long (type, valaddr, i));
-
- if (v == NULL)
- fputs_filtered ("<optimized out>", stream);
- else
- pascal_object_print_static_field (TYPE_FIELD_TYPE (type, i), v,
- stream, format, recurse + 1,
- pretty);
- }
- else
- {
- /* val_print (TYPE_FIELD_TYPE (type, i),
- valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
- address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
- stream, format, 0, recurse + 1, pretty); */
- val_print (TYPE_FIELD_TYPE (type, i),
- valaddr, TYPE_FIELD_BITPOS (type, i) / 8,
- address + TYPE_FIELD_BITPOS (type, i) / 8,
- stream, format, 0, recurse + 1, pretty);
- }
- }
- annotate_field_end ();
- }
-
- if (dont_print_statmem == 0)
- {
- /* Free the space used to deal with the printing
- of the members from top level. */
- obstack_free (&dont_print_statmem_obstack, last_dont_print);
- dont_print_statmem_obstack = tmp_obstack;
- }
-
- if (pretty)
- {
- fprintf_filtered (stream, "\n");
- print_spaces_filtered (2 * recurse, stream);
- }
- }
- fprintf_filtered (stream, "}");
-}
-
-/* Special val_print routine to avoid printing multiple copies of virtual
- baseclasses. */
-
-void
-pascal_object_print_value (struct type *type, char *valaddr, CORE_ADDR address,
- struct ui_file *stream, int format, int recurse,
- enum val_prettyprint pretty,
- struct type **dont_print_vb)
-{
- struct obstack tmp_obstack;
- struct type **last_dont_print
- = (struct type **) obstack_next_free (&dont_print_vb_obstack);
- int i, n_baseclasses = TYPE_N_BASECLASSES (type);
-
- if (dont_print_vb == 0)
- {
- /* If we're at top level, carve out a completely fresh
- chunk of the obstack and use that until this particular
- invocation returns. */
- tmp_obstack = dont_print_vb_obstack;
- /* Bump up the high-water mark. Now alpha is omega. */
- obstack_finish (&dont_print_vb_obstack);
- }
-
- for (i = 0; i < n_baseclasses; i++)
- {
- int boffset;
- struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
- char *basename = TYPE_NAME (baseclass);
- char *base_valaddr;
-
- if (BASETYPE_VIA_VIRTUAL (type, i))
- {
- struct type **first_dont_print
- = (struct type **) obstack_base (&dont_print_vb_obstack);
-
- int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
- - first_dont_print;
-
- while (--j >= 0)
- if (baseclass == first_dont_print[j])
- goto flush_it;
-
- obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
- }
-
- boffset = baseclass_offset (type, i, valaddr, address);
-
- if (pretty)
- {
- fprintf_filtered (stream, "\n");
- print_spaces_filtered (2 * recurse, stream);
- }
- fputs_filtered ("<", stream);
- /* Not sure what the best notation is in the case where there is no
- baseclass name. */
-
- fputs_filtered (basename ? basename : "", stream);
- fputs_filtered ("> = ", stream);
-
- /* The virtual base class pointer might have been clobbered by the
- user program. Make sure that it still points to a valid memory
- location. */
-
- if (boffset != -1 && (boffset < 0 || boffset >= TYPE_LENGTH (type)))
- {
- base_valaddr = (char *) alloca (TYPE_LENGTH (baseclass));
- if (target_read_memory (address + boffset, base_valaddr,
- TYPE_LENGTH (baseclass)) != 0)
- boffset = -1;
- }
- else
- base_valaddr = valaddr + boffset;
-
- if (boffset == -1)
- fprintf_filtered (stream, "<invalid address>");
- else
- pascal_object_print_value_fields (baseclass, base_valaddr, address + boffset,
- stream, format, recurse, pretty,
- (struct type **) obstack_base (&dont_print_vb_obstack),
- 0);
- fputs_filtered (", ", stream);
-
- flush_it:
- ;
- }
-
- if (dont_print_vb == 0)
- {
- /* Free the space used to deal with the printing
- of this type from top level. */
- obstack_free (&dont_print_vb_obstack, last_dont_print);
- /* Reset watermark so that we can continue protecting
- ourselves from whatever we were protecting ourselves. */
- dont_print_vb_obstack = tmp_obstack;
- }
-}
-
-/* Print value of a static member.
- To avoid infinite recursion when printing a class that contains
- a static instance of the class, we keep the addresses of all printed
- static member classes in an obstack and refuse to print them more
- than once.
-
- VAL contains the value to print, TYPE, STREAM, RECURSE, and PRETTY
- have the same meanings as in c_val_print. */
-
-static void
-pascal_object_print_static_field (struct type *type, value_ptr val,
- struct ui_file *stream, int format,
- int recurse, enum val_prettyprint pretty)
-{
- if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
- {
- CORE_ADDR *first_dont_print;
- int i;
-
- first_dont_print
- = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
- i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
- - first_dont_print;
-
- while (--i >= 0)
- {
- if (VALUE_ADDRESS (val) == first_dont_print[i])
- {
- fputs_filtered ("<same as static member of an already seen type>",
- stream);
- return;
- }
- }
-
- obstack_grow (&dont_print_statmem_obstack, (char *) &VALUE_ADDRESS (val),
- sizeof (CORE_ADDR));
-
- CHECK_TYPEDEF (type);
- pascal_object_print_value_fields (type, VALUE_CONTENTS (val), VALUE_ADDRESS (val),
- stream, format, recurse, pretty, NULL, 1);
- return;
- }
- val_print (type, VALUE_CONTENTS (val), 0, VALUE_ADDRESS (val),
- stream, format, 0, recurse, pretty);
-}
-
-void
-pascal_object_print_class_member (char *valaddr, struct type *domain,
- struct ui_file *stream, char *prefix)
-{
-
- /* VAL is a byte offset into the structure type DOMAIN.
- Find the name of the field for that offset and
- print it. */
- int extra = 0;
- int bits = 0;
- register unsigned int i;
- unsigned len = TYPE_NFIELDS (domain);
- /* @@ Make VAL into bit offset */
- LONGEST val = unpack_long (builtin_type_int, valaddr) << 3;
- for (i = TYPE_N_BASECLASSES (domain); i < len; i++)
- {
- int bitpos = TYPE_FIELD_BITPOS (domain, i);
- QUIT;
- if (val == bitpos)
- break;
- if (val < bitpos && i != 0)
- {
- /* Somehow pointing into a field. */
- i -= 1;
- extra = (val - TYPE_FIELD_BITPOS (domain, i));
- if (extra & 0x7)
- bits = 1;
- else
- extra >>= 3;
- break;
- }
- }
- if (i < len)
- {
- char *name;
- fprintf_filtered (stream, prefix);
- name = type_name_no_tag (domain);
- if (name)
- fputs_filtered (name, stream);
- else
- pascal_type_print_base (domain, stream, 0, 0);
- fprintf_filtered (stream, "::");
- fputs_filtered (TYPE_FIELD_NAME (domain, i), stream);
- if (extra)
- fprintf_filtered (stream, " + %d bytes", extra);
- if (bits)
- fprintf_filtered (stream, " (offset in bits)");
- }
- else
- fprintf_filtered (stream, "%ld", (long int) (val >> 3));
-}
-
-
-void
-_initialize_pascal_valprint (void)
-{
- add_show_from_set
- (add_set_cmd ("pascal_static-members", class_support, var_boolean,
- (char *) &pascal_static_field_print,
- "Set printing of pascal static members.",
- &setprintlist),
- &showprintlist);
- /* Turn on printing of static fields. */
- pascal_static_field_print = 1;
-
-}
+/* Support for printing Pascal values for GDB, the GNU debugger.\r
+ Copyright 2000\r
+ Free Software Foundation, Inc.\r
+\r
+ This file is part of GDB.\r
+\r
+ This program is free software; you can redistribute it and/or modify\r
+ it under the terms of the GNU General Public License as published by\r
+ the Free Software Foundation; either version 2 of the License, or\r
+ (at your option) any later version.\r
+\r
+ This program is distributed in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+ GNU General Public License for more details.\r
+\r
+ You should have received a copy of the GNU General Public License\r
+ along with this program; if not, write to the Free Software\r
+ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */\r
+\r
+/* This file is derived from c-valprint.c */\r
+\r
+#include "defs.h"\r
+#include "obstack.h"\r
+#include "symtab.h"\r
+#include "gdbtypes.h"\r
+#include "expression.h"\r
+#include "value.h"\r
+#include "command.h"\r
+#include "gdbcmd.h"\r
+#include "gdbcore.h"\r
+#include "demangle.h"\r
+#include "valprint.h"\r
+#include "typeprint.h"\r
+#include "language.h"\r
+#include "target.h"\r
+#include "annotate.h"\r
+#include "p-lang.h"\r
+\f\r
+\r
+\r
+\r
+/* Print data of type TYPE located at VALADDR (within GDB), which came from\r
+ the inferior at address ADDRESS, onto stdio stream STREAM according to\r
+ FORMAT (a letter or 0 for natural format). The data at VALADDR is in\r
+ target byte order.\r
+\r
+ If the data are a string pointer, returns the number of string characters\r
+ printed.\r
+\r
+ If DEREF_REF is nonzero, then dereference references, otherwise just print\r
+ them like pointers.\r
+\r
+ The PRETTY parameter controls prettyprinting. */\r
+\r
+\r
+int\r
+pascal_val_print (struct type *type, char *valaddr, int embedded_offset,\r
+ CORE_ADDR address, struct ui_file *stream, int format,\r
+ int deref_ref, int recurse, enum val_prettyprint pretty)\r
+{\r
+ register unsigned int i = 0; /* Number of characters printed */\r
+ unsigned len;\r
+ struct type *elttype;\r
+ unsigned eltlen;\r
+ int length_pos, length_size, string_pos;\r
+ int char_size;\r
+ LONGEST val;\r
+ CORE_ADDR addr;\r
+\r
+ CHECK_TYPEDEF (type);\r
+ switch (TYPE_CODE (type))\r
+ {\r
+ case TYPE_CODE_ARRAY:\r
+ if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)\r
+ {\r
+ elttype = check_typedef (TYPE_TARGET_TYPE (type));\r
+ eltlen = TYPE_LENGTH (elttype);\r
+ len = TYPE_LENGTH (type) / eltlen;\r
+ if (prettyprint_arrays)\r
+ {\r
+ print_spaces_filtered (2 + 2 * recurse, stream);\r
+ }\r
+ /* For an array of chars, print with string syntax. */\r
+ if (eltlen == 1 &&\r
+ ((TYPE_CODE (elttype) == TYPE_CODE_INT)\r
+ || ((current_language->la_language == language_m2)\r
+ && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))\r
+ && (format == 0 || format == 's'))\r
+ {\r
+ /* If requested, look for the first null char and only print\r
+ elements up to it. */\r
+ if (stop_print_at_null)\r
+ {\r
+ unsigned int temp_len;\r
+\r
+ /* Look for a NULL char. */\r
+ for (temp_len = 0;\r
+ (valaddr + embedded_offset)[temp_len]\r
+ && temp_len < len && temp_len < print_max;\r
+ temp_len++);\r
+ len = temp_len;\r
+ }\r
+\r
+ LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);\r
+ i = len;\r
+ }\r
+ else\r
+ {\r
+ fprintf_filtered (stream, "{");\r
+ /* If this is a virtual function table, print the 0th\r
+ entry specially, and the rest of the members normally. */\r
+ if (pascal_object_is_vtbl_ptr_type (elttype))\r
+ {\r
+ i = 1;\r
+ fprintf_filtered (stream, "%d vtable entries", len - 1);\r
+ }\r
+ else\r
+ {\r
+ i = 0;\r
+ }\r
+ val_print_array_elements (type, valaddr + embedded_offset, address, stream,\r
+ format, deref_ref, recurse, pretty, i);\r
+ fprintf_filtered (stream, "}");\r
+ }\r
+ break;\r
+ }\r
+ /* Array of unspecified length: treat like pointer to first elt. */\r
+ addr = address;\r
+ goto print_unpacked_pointer;\r
+\r
+ case TYPE_CODE_PTR:\r
+ if (format && format != 's')\r
+ {\r
+ print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);\r
+ break;\r
+ }\r
+ if (vtblprint && pascal_object_is_vtbl_ptr_type (type))\r
+ {\r
+ /* Print the unmangled name if desired. */\r
+ /* Print vtable entry - we only get here if we ARE using\r
+ -fvtable_thunks. (Otherwise, look under TYPE_CODE_STRUCT.) */\r
+ print_address_demangle (extract_address (valaddr + embedded_offset, TYPE_LENGTH (type)),\r
+ stream, demangle);\r
+ break;\r
+ }\r
+ elttype = check_typedef (TYPE_TARGET_TYPE (type));\r
+ if (TYPE_CODE (elttype) == TYPE_CODE_METHOD)\r
+ {\r
+ pascal_object_print_class_method (valaddr + embedded_offset, type, stream);\r
+ }\r
+ else if (TYPE_CODE (elttype) == TYPE_CODE_MEMBER)\r
+ {\r
+ pascal_object_print_class_member (valaddr + embedded_offset,\r
+ TYPE_DOMAIN_TYPE (TYPE_TARGET_TYPE (type)),\r
+ stream, "&");\r
+ }\r
+ else\r
+ {\r
+ addr = unpack_pointer (type, valaddr + embedded_offset);\r
+ print_unpacked_pointer:\r
+ elttype = check_typedef (TYPE_TARGET_TYPE (type));\r
+\r
+ if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)\r
+ {\r
+ /* Try to print what function it points to. */\r
+ print_address_demangle (addr, stream, demangle);\r
+ /* Return value is irrelevant except for string pointers. */\r
+ return (0);\r
+ }\r
+\r
+ if (addressprint && format != 's')\r
+ {\r
+ print_address_numeric (addr, 1, stream);\r
+ }\r
+\r
+ /* For a pointer to char or unsigned char, also print the string\r
+ pointed to, unless pointer is null. */\r
+ if (TYPE_LENGTH (elttype) == 1\r
+ && TYPE_CODE (elttype) == TYPE_CODE_INT\r
+ && (format == 0 || format == 's')\r
+ && addr != 0)\r
+ {\r
+ /* no wide string yet */\r
+ i = val_print_string (addr, -1, 1, stream);\r
+ }\r
+ /* also for pointers to pascal strings */\r
+ /* Note: this is Free Pascal specific:\r
+ as GDB does not recognize stabs pascal strings\r
+ Pascal strings are mapped to records\r
+ with lowercase names PM */\r
+ if (is_pascal_string_type (elttype, &length_pos,\r
+ &length_size, &string_pos, &char_size)\r
+ && addr != 0)\r
+ {\r
+ ULONGEST string_length;\r
+ void *buffer;\r
+ buffer = xmalloc (length_size);\r
+ read_memory (addr + length_pos, buffer, length_size);\r
+ string_length = extract_unsigned_integer (buffer, length_size);\r
+ xfree (buffer);\r
+ i = val_print_string (addr + string_pos, string_length, char_size, stream);\r
+ }\r
+ else if (pascal_object_is_vtbl_member (type))\r
+ {\r
+ /* print vtbl's nicely */\r
+ CORE_ADDR vt_address = unpack_pointer (type, valaddr + embedded_offset);\r
+\r
+ struct minimal_symbol *msymbol =\r
+ lookup_minimal_symbol_by_pc (vt_address);\r
+ if ((msymbol != NULL)\r
+ && (vt_address == SYMBOL_VALUE_ADDRESS (msymbol)))\r
+ {\r
+ fputs_filtered (" <", stream);\r
+ fputs_filtered (SYMBOL_SOURCE_NAME (msymbol), stream);\r
+ fputs_filtered (">", stream);\r
+ }\r
+ if (vt_address && vtblprint)\r
+ {\r
+ value_ptr vt_val;\r
+ struct symbol *wsym = (struct symbol *) NULL;\r
+ struct type *wtype;\r
+ struct symtab *s;\r
+ struct block *block = (struct block *) NULL;\r
+ int is_this_fld;\r
+\r
+ if (msymbol != NULL)\r
+ wsym = lookup_symbol (SYMBOL_NAME (msymbol), block,\r
+ VAR_NAMESPACE, &is_this_fld, &s);\r
+\r
+ if (wsym)\r
+ {\r
+ wtype = SYMBOL_TYPE (wsym);\r
+ }\r
+ else\r
+ {\r
+ wtype = TYPE_TARGET_TYPE (type);\r
+ }\r
+ vt_val = value_at (wtype, vt_address, NULL);\r
+ val_print (VALUE_TYPE (vt_val), VALUE_CONTENTS (vt_val), 0,\r
+ VALUE_ADDRESS (vt_val), stream, format,\r
+ deref_ref, recurse + 1, pretty);\r
+ if (pretty)\r
+ {\r
+ fprintf_filtered (stream, "\n");\r
+ print_spaces_filtered (2 + 2 * recurse, stream);\r
+ }\r
+ }\r
+ }\r
+\r
+ /* Return number of characters printed, including the terminating\r
+ '\0' if we reached the end. val_print_string takes care including\r
+ the terminating '\0' if necessary. */\r
+ return i;\r
+ }\r
+ break;\r
+\r
+ case TYPE_CODE_MEMBER:\r
+ error ("not implemented: member type in pascal_val_print");\r
+ break;\r
+\r
+ case TYPE_CODE_REF:\r
+ elttype = check_typedef (TYPE_TARGET_TYPE (type));\r
+ if (TYPE_CODE (elttype) == TYPE_CODE_MEMBER)\r
+ {\r
+ pascal_object_print_class_member (valaddr + embedded_offset,\r
+ TYPE_DOMAIN_TYPE (elttype),\r
+ stream, "");\r
+ break;\r
+ }\r
+ if (addressprint)\r
+ {\r
+ fprintf_filtered (stream, "@");\r
+ print_address_numeric\r
+ (extract_address (valaddr + embedded_offset,\r
+ TARGET_PTR_BIT / HOST_CHAR_BIT), 1, stream);\r
+ if (deref_ref)\r
+ fputs_filtered (": ", stream);\r
+ }\r
+ /* De-reference the reference. */\r
+ if (deref_ref)\r
+ {\r
+ if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)\r
+ {\r
+ value_ptr deref_val =\r
+ value_at\r
+ (TYPE_TARGET_TYPE (type),\r
+ unpack_pointer (lookup_pointer_type (builtin_type_void),\r
+ valaddr + embedded_offset),\r
+ NULL);\r
+ val_print (VALUE_TYPE (deref_val),\r
+ VALUE_CONTENTS (deref_val), 0,\r
+ VALUE_ADDRESS (deref_val), stream, format,\r
+ deref_ref, recurse + 1, pretty);\r
+ }\r
+ else\r
+ fputs_filtered ("???", stream);\r
+ }\r
+ break;\r
+\r
+ case TYPE_CODE_UNION:\r
+ if (recurse && !unionprint)\r
+ {\r
+ fprintf_filtered (stream, "{...}");\r
+ break;\r
+ }\r
+ /* Fall through. */\r
+ case TYPE_CODE_STRUCT:\r
+ if (vtblprint && pascal_object_is_vtbl_ptr_type (type))\r
+ {\r
+ /* Print the unmangled name if desired. */\r
+ /* Print vtable entry - we only get here if NOT using\r
+ -fvtable_thunks. (Otherwise, look under TYPE_CODE_PTR.) */\r
+ print_address_demangle (extract_address (\r
+ valaddr + embedded_offset + TYPE_FIELD_BITPOS (type, VTBL_FNADDR_OFFSET) / 8,\r
+ TYPE_LENGTH (TYPE_FIELD_TYPE (type, VTBL_FNADDR_OFFSET))),\r
+ stream, demangle);\r
+ }\r
+ else\r
+ {\r
+ if (is_pascal_string_type (type, &length_pos, &length_size,\r
+ &string_pos, &char_size))\r
+ {\r
+ len = extract_unsigned_integer (valaddr + embedded_offset + length_pos, length_size);\r
+ LA_PRINT_STRING (stream, valaddr + embedded_offset + string_pos, len, char_size, 0);\r
+ }\r
+ else\r
+ pascal_object_print_value_fields (type, valaddr + embedded_offset, address, stream, format,\r
+ recurse, pretty, NULL, 0);\r
+ }\r
+ break;\r
+\r
+ case TYPE_CODE_ENUM:\r
+ if (format)\r
+ {\r
+ print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);\r
+ break;\r
+ }\r
+ len = TYPE_NFIELDS (type);\r
+ val = unpack_long (type, valaddr + embedded_offset);\r
+ for (i = 0; i < len; i++)\r
+ {\r
+ QUIT;\r
+ if (val == TYPE_FIELD_BITPOS (type, i))\r
+ {\r
+ break;\r
+ }\r
+ }\r
+ if (i < len)\r
+ {\r
+ fputs_filtered (TYPE_FIELD_NAME (type, i), stream);\r
+ }\r
+ else\r
+ {\r
+ print_longest (stream, 'd', 0, val);\r
+ }\r
+ break;\r
+\r
+ case TYPE_CODE_FUNC:\r
+ if (format)\r
+ {\r
+ print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);\r
+ break;\r
+ }\r
+ /* FIXME, we should consider, at least for ANSI C language, eliminating\r
+ the distinction made between FUNCs and POINTERs to FUNCs. */\r
+ fprintf_filtered (stream, "{");\r
+ type_print (type, "", stream, -1);\r
+ fprintf_filtered (stream, "} ");\r
+ /* Try to print what function it points to, and its address. */\r
+ print_address_demangle (address, stream, demangle);\r
+ break;\r
+\r
+ case TYPE_CODE_BOOL:\r
+ format = format ? format : output_format;\r
+ if (format)\r
+ print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);\r
+ else\r
+ {\r
+ val = unpack_long (type, valaddr + embedded_offset);\r
+ if (val == 0)\r
+ fputs_filtered ("false", stream);\r
+ else if (val == 1)\r
+ fputs_filtered ("true", stream);\r
+ else\r
+ {\r
+ fputs_filtered ("true (", stream);\r
+ fprintf_filtered (stream, "%ld)", (long int) val);\r
+ }\r
+ }\r
+ break;\r
+\r
+ case TYPE_CODE_RANGE:\r
+ /* FIXME: create_range_type does not set the unsigned bit in a\r
+ range type (I think it probably should copy it from the target\r
+ type), so we won't print values which are too large to\r
+ fit in a signed integer correctly. */\r
+ /* FIXME: Doesn't handle ranges of enums correctly. (Can't just\r
+ print with the target type, though, because the size of our type\r
+ and the target type might differ). */\r
+ /* FALLTHROUGH */\r
+\r
+ case TYPE_CODE_INT:\r
+ format = format ? format : output_format;\r
+ if (format)\r
+ {\r
+ print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);\r
+ }\r
+ else\r
+ {\r
+ val_print_type_code_int (type, valaddr + embedded_offset, stream);\r
+ }\r
+ break;\r
+\r
+ case TYPE_CODE_CHAR:\r
+ format = format ? format : output_format;\r
+ if (format)\r
+ {\r
+ print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);\r
+ }\r
+ else\r
+ {\r
+ val = unpack_long (type, valaddr + embedded_offset);\r
+ if (TYPE_UNSIGNED (type))\r
+ fprintf_filtered (stream, "%u", (unsigned int) val);\r
+ else\r
+ fprintf_filtered (stream, "%d", (int) val);\r
+ fputs_filtered (" ", stream);\r
+ LA_PRINT_CHAR ((unsigned char) val, stream);\r
+ }\r
+ break;\r
+\r
+ case TYPE_CODE_FLT:\r
+ if (format)\r
+ {\r
+ print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);\r
+ }\r
+ else\r
+ {\r
+ print_floating (valaddr + embedded_offset, type, stream);\r
+ }\r
+ break;\r
+\r
+ case TYPE_CODE_BITSTRING:\r
+ case TYPE_CODE_SET:\r
+ elttype = TYPE_INDEX_TYPE (type);\r
+ CHECK_TYPEDEF (elttype);\r
+ if (TYPE_FLAGS (elttype) & TYPE_FLAG_STUB)\r
+ {\r
+ fprintf_filtered (stream, "<incomplete type>");\r
+ gdb_flush (stream);\r
+ break;\r
+ }\r
+ else\r
+ {\r
+ struct type *range = elttype;\r
+ LONGEST low_bound, high_bound;\r
+ int i;\r
+ int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;\r
+ int need_comma = 0;\r
+\r
+ if (is_bitstring)\r
+ fputs_filtered ("B'", stream);\r
+ else\r
+ fputs_filtered ("[", stream);\r
+\r
+ i = get_discrete_bounds (range, &low_bound, &high_bound);\r
+ maybe_bad_bstring:\r
+ if (i < 0)\r
+ {\r
+ fputs_filtered ("<error value>", stream);\r
+ goto done;\r
+ }\r
+\r
+ for (i = low_bound; i <= high_bound; i++)\r
+ {\r
+ int element = value_bit_index (type, valaddr + embedded_offset, i);\r
+ if (element < 0)\r
+ {\r
+ i = element;\r
+ goto maybe_bad_bstring;\r
+ }\r
+ if (is_bitstring)\r
+ fprintf_filtered (stream, "%d", element);\r
+ else if (element)\r
+ {\r
+ if (need_comma)\r
+ fputs_filtered (", ", stream);\r
+ print_type_scalar (range, i, stream);\r
+ need_comma = 1;\r
+\r
+ if (i + 1 <= high_bound && value_bit_index (type, valaddr + embedded_offset, ++i))\r
+ {\r
+ int j = i;\r
+ fputs_filtered ("..", stream);\r
+ while (i + 1 <= high_bound\r
+ && value_bit_index (type, valaddr + embedded_offset, ++i))\r
+ j = i;\r
+ print_type_scalar (range, j, stream);\r
+ }\r
+ }\r
+ }\r
+ done:\r
+ if (is_bitstring)\r
+ fputs_filtered ("'", stream);\r
+ else\r
+ fputs_filtered ("]", stream);\r
+ }\r
+ break;\r
+\r
+ case TYPE_CODE_VOID:\r
+ fprintf_filtered (stream, "void");\r
+ break;\r
+\r
+ case TYPE_CODE_ERROR:\r
+ fprintf_filtered (stream, "<error type>");\r
+ break;\r
+\r
+ case TYPE_CODE_UNDEF:\r
+ /* This happens (without TYPE_FLAG_STUB set) on systems which don't use\r
+ dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"\r
+ and no complete type for struct foo in that file. */\r
+ fprintf_filtered (stream, "<incomplete type>");\r
+ break;\r
+\r
+ default:\r
+ error ("Invalid pascal type code %d in symbol table.", TYPE_CODE (type));\r
+ }\r
+ gdb_flush (stream);\r
+ return (0);\r
+}\r
+\f\r
+int\r
+pascal_value_print (value_ptr val, struct ui_file *stream, int format,\r
+ enum val_prettyprint pretty)\r
+{\r
+ struct type *type = VALUE_TYPE (val);\r
+\r
+ /* If it is a pointer, indicate what it points to.\r
+\r
+ Print type also if it is a reference.\r
+\r
+ Object pascal: if it is a member pointer, we will take care\r
+ of that when we print it. */\r
+ if (TYPE_CODE (type) == TYPE_CODE_PTR ||\r
+ TYPE_CODE (type) == TYPE_CODE_REF)\r
+ {\r
+ /* Hack: remove (char *) for char strings. Their\r
+ type is indicated by the quoted string anyway. */\r
+ if (TYPE_CODE (type) == TYPE_CODE_PTR &&\r
+ TYPE_NAME (type) == NULL &&\r
+ TYPE_NAME (TYPE_TARGET_TYPE (type)) != NULL &&\r
+ STREQ (TYPE_NAME (TYPE_TARGET_TYPE (type)), "char"))\r
+ {\r
+ /* Print nothing */\r
+ }\r
+ else\r
+ {\r
+ fprintf_filtered (stream, "(");\r
+ type_print (type, "", stream, -1);\r
+ fprintf_filtered (stream, ") ");\r
+ }\r
+ }\r
+ return val_print (type, VALUE_CONTENTS (val), VALUE_EMBEDDED_OFFSET (val),\r
+ VALUE_ADDRESS (val) + VALUE_OFFSET (val),\r
+ stream, format, 1, 0, pretty);\r
+}\r
+\r
+\r
+/******************************************************************************\r
+ Inserted from cp-valprint\r
+******************************************************************************/\r
+\r
+extern int vtblprint; /* Controls printing of vtbl's */\r
+extern int objectprint; /* Controls looking up an object's derived type\r
+ using what we find in its vtables. */\r
+static int pascal_static_field_print; /* Controls printing of static fields. */\r
+\r
+static struct obstack dont_print_vb_obstack;\r
+static struct obstack dont_print_statmem_obstack;\r
+\r
+static void\r
+ pascal_object_print_static_field (struct type *, value_ptr, struct ui_file *, int, int,\r
+ enum val_prettyprint);\r
+\r
+static void\r
+ pascal_object_print_value (struct type *, char *, CORE_ADDR, struct ui_file *,\r
+ int, int, enum val_prettyprint, struct type **);\r
+\r
+void\r
+pascal_object_print_class_method (char *valaddr, struct type *type,\r
+ struct ui_file *stream)\r
+{\r
+ struct type *domain;\r
+ struct fn_field *f = NULL;\r
+ int j = 0;\r
+ int len2;\r
+ int offset;\r
+ char *kind = "";\r
+ CORE_ADDR addr;\r
+ struct symbol *sym;\r
+ unsigned len;\r
+ unsigned int i;\r
+ struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));\r
+\r
+ domain = TYPE_DOMAIN_TYPE (target_type);\r
+ if (domain == (struct type *) NULL)\r
+ {\r
+ fprintf_filtered (stream, "<unknown>");\r
+ return;\r
+ }\r
+ addr = unpack_pointer (lookup_pointer_type (builtin_type_void), valaddr);\r
+ if (METHOD_PTR_IS_VIRTUAL (addr))\r
+ {\r
+ offset = METHOD_PTR_TO_VOFFSET (addr);\r
+ len = TYPE_NFN_FIELDS (domain);\r
+ for (i = 0; i < len; i++)\r
+ {\r
+ f = TYPE_FN_FIELDLIST1 (domain, i);\r
+ len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);\r
+\r
+ for (j = 0; j < len2; j++)\r
+ {\r
+ QUIT;\r
+ if (TYPE_FN_FIELD_VOFFSET (f, j) == offset)\r
+ {\r
+ if (TYPE_FN_FIELD_STUB (f, j))\r
+ check_stub_method (domain, i, j);\r
+ kind = "virtual ";\r
+ goto common;\r
+ }\r
+ }\r
+ }\r
+ }\r
+ else\r
+ {\r
+ sym = find_pc_function (addr);\r
+ if (sym == 0)\r
+ {\r
+ error ("invalid pointer to member function");\r
+ }\r
+ len = TYPE_NFN_FIELDS (domain);\r
+ for (i = 0; i < len; i++)\r
+ {\r
+ f = TYPE_FN_FIELDLIST1 (domain, i);\r
+ len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);\r
+\r
+ for (j = 0; j < len2; j++)\r
+ {\r
+ QUIT;\r
+ if (TYPE_FN_FIELD_STUB (f, j))\r
+ check_stub_method (domain, i, j);\r
+ if (STREQ (SYMBOL_NAME (sym), TYPE_FN_FIELD_PHYSNAME (f, j)))\r
+ {\r
+ goto common;\r
+ }\r
+ }\r
+ }\r
+ }\r
+common:\r
+ if (i < len)\r
+ {\r
+ char *demangled_name;\r
+\r
+ fprintf_filtered (stream, "&");\r
+ fprintf_filtered (stream, kind);\r
+ demangled_name = cplus_demangle (TYPE_FN_FIELD_PHYSNAME (f, j),\r
+ DMGL_ANSI | DMGL_PARAMS);\r
+ if (demangled_name == NULL)\r
+ fprintf_filtered (stream, "<badly mangled name %s>",\r
+ TYPE_FN_FIELD_PHYSNAME (f, j));\r
+ else\r
+ {\r
+ fputs_filtered (demangled_name, stream);\r
+ xfree (demangled_name);\r
+ }\r
+ }\r
+ else\r
+ {\r
+ fprintf_filtered (stream, "(");\r
+ type_print (type, "", stream, -1);\r
+ fprintf_filtered (stream, ") %d", (int) addr >> 3);\r
+ }\r
+}\r
+\r
+/* It was changed to this after 2.4.5. */\r
+const char pascal_vtbl_ptr_name[] =\r
+{'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};\r
+\r
+/* Return truth value for assertion that TYPE is of the type\r
+ "pointer to virtual function". */\r
+\r
+int\r
+pascal_object_is_vtbl_ptr_type (struct type *type)\r
+{\r
+ char *typename = type_name_no_tag (type);\r
+\r
+ return (typename != NULL\r
+ && (STREQ (typename, pascal_vtbl_ptr_name)));\r
+}\r
+\r
+/* Return truth value for the assertion that TYPE is of the type\r
+ "pointer to virtual function table". */\r
+\r
+int\r
+pascal_object_is_vtbl_member (struct type *type)\r
+{\r
+ if (TYPE_CODE (type) == TYPE_CODE_PTR)\r
+ {\r
+ type = TYPE_TARGET_TYPE (type);\r
+ if (TYPE_CODE (type) == TYPE_CODE_ARRAY)\r
+ {\r
+ type = TYPE_TARGET_TYPE (type);\r
+ if (TYPE_CODE (type) == TYPE_CODE_STRUCT /* if not using thunks */\r
+ || TYPE_CODE (type) == TYPE_CODE_PTR) /* if using thunks */\r
+ {\r
+ /* Virtual functions tables are full of pointers\r
+ to virtual functions. */\r
+ return pascal_object_is_vtbl_ptr_type (type);\r
+ }\r
+ }\r
+ }\r
+ return 0;\r
+}\r
+\r
+/* Mutually recursive subroutines of pascal_object_print_value and c_val_print to\r
+ print out a structure's fields: pascal_object_print_value_fields and pascal_object_print_value.\r
+\r
+ TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and PRETTY have the\r
+ same meanings as in pascal_object_print_value and c_val_print.\r
+\r
+ DONT_PRINT is an array of baseclass types that we\r
+ should not print, or zero if called from top level. */\r
+\r
+void\r
+pascal_object_print_value_fields (struct type *type, char *valaddr,\r
+ CORE_ADDR address, struct ui_file *stream,\r
+ int format, int recurse,\r
+ enum val_prettyprint pretty,\r
+ struct type **dont_print_vb,\r
+ int dont_print_statmem)\r
+{\r
+ int i, len, n_baseclasses;\r
+ struct obstack tmp_obstack;\r
+ char *last_dont_print = obstack_next_free (&dont_print_statmem_obstack);\r
+\r
+ CHECK_TYPEDEF (type);\r
+\r
+ fprintf_filtered (stream, "{");\r
+ len = TYPE_NFIELDS (type);\r
+ n_baseclasses = TYPE_N_BASECLASSES (type);\r
+\r
+ /* Print out baseclasses such that we don't print\r
+ duplicates of virtual baseclasses. */\r
+ if (n_baseclasses > 0)\r
+ pascal_object_print_value (type, valaddr, address, stream,\r
+ format, recurse + 1, pretty, dont_print_vb);\r
+\r
+ if (!len && n_baseclasses == 1)\r
+ fprintf_filtered (stream, "<No data fields>");\r
+ else\r
+ {\r
+ extern int inspect_it;\r
+ int fields_seen = 0;\r
+\r
+ if (dont_print_statmem == 0)\r
+ {\r
+ /* If we're at top level, carve out a completely fresh\r
+ chunk of the obstack and use that until this particular\r
+ invocation returns. */\r
+ tmp_obstack = dont_print_statmem_obstack;\r
+ obstack_finish (&dont_print_statmem_obstack);\r
+ }\r
+\r
+ for (i = n_baseclasses; i < len; i++)\r
+ {\r
+ /* If requested, skip printing of static fields. */\r
+ if (!pascal_static_field_print && TYPE_FIELD_STATIC (type, i))\r
+ continue;\r
+ if (fields_seen)\r
+ fprintf_filtered (stream, ", ");\r
+ else if (n_baseclasses > 0)\r
+ {\r
+ if (pretty)\r
+ {\r
+ fprintf_filtered (stream, "\n");\r
+ print_spaces_filtered (2 + 2 * recurse, stream);\r
+ fputs_filtered ("members of ", stream);\r
+ fputs_filtered (type_name_no_tag (type), stream);\r
+ fputs_filtered (": ", stream);\r
+ }\r
+ }\r
+ fields_seen = 1;\r
+\r
+ if (pretty)\r
+ {\r
+ fprintf_filtered (stream, "\n");\r
+ print_spaces_filtered (2 + 2 * recurse, stream);\r
+ }\r
+ else\r
+ {\r
+ wrap_here (n_spaces (2 + 2 * recurse));\r
+ }\r
+ if (inspect_it)\r
+ {\r
+ if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) == TYPE_CODE_PTR)\r
+ fputs_filtered ("\"( ptr \"", stream);\r
+ else\r
+ fputs_filtered ("\"( nodef \"", stream);\r
+ if (TYPE_FIELD_STATIC (type, i))\r
+ fputs_filtered ("static ", stream);\r
+ fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),\r
+ language_cplus,\r
+ DMGL_PARAMS | DMGL_ANSI);\r
+ fputs_filtered ("\" \"", stream);\r
+ fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),\r
+ language_cplus,\r
+ DMGL_PARAMS | DMGL_ANSI);\r
+ fputs_filtered ("\") \"", stream);\r
+ }\r
+ else\r
+ {\r
+ annotate_field_begin (TYPE_FIELD_TYPE (type, i));\r
+\r
+ if (TYPE_FIELD_STATIC (type, i))\r
+ fputs_filtered ("static ", stream);\r
+ fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),\r
+ language_cplus,\r
+ DMGL_PARAMS | DMGL_ANSI);\r
+ annotate_field_name_end ();\r
+ fputs_filtered (" = ", stream);\r
+ annotate_field_value ();\r
+ }\r
+\r
+ if (!TYPE_FIELD_STATIC (type, i) && TYPE_FIELD_PACKED (type, i))\r
+ {\r
+ value_ptr v;\r
+\r
+ /* Bitfields require special handling, especially due to byte\r
+ order problems. */\r
+ if (TYPE_FIELD_IGNORE (type, i))\r
+ {\r
+ fputs_filtered ("<optimized out or zero length>", stream);\r
+ }\r
+ else\r
+ {\r
+ v = value_from_longest (TYPE_FIELD_TYPE (type, i),\r
+ unpack_field_as_long (type, valaddr, i));\r
+\r
+ val_print (TYPE_FIELD_TYPE (type, i), VALUE_CONTENTS (v), 0, 0,\r
+ stream, format, 0, recurse + 1, pretty);\r
+ }\r
+ }\r
+ else\r
+ {\r
+ if (TYPE_FIELD_IGNORE (type, i))\r
+ {\r
+ fputs_filtered ("<optimized out or zero length>", stream);\r
+ }\r
+ else if (TYPE_FIELD_STATIC (type, i))\r
+ {\r
+ /* value_ptr v = value_static_field (type, i); v4.17 specific */\r
+ value_ptr v;\r
+ v = value_from_longest (TYPE_FIELD_TYPE (type, i),\r
+ unpack_field_as_long (type, valaddr, i));\r
+\r
+ if (v == NULL)\r
+ fputs_filtered ("<optimized out>", stream);\r
+ else\r
+ pascal_object_print_static_field (TYPE_FIELD_TYPE (type, i), v,\r
+ stream, format, recurse + 1,\r
+ pretty);\r
+ }\r
+ else\r
+ {\r
+ /* val_print (TYPE_FIELD_TYPE (type, i),\r
+ valaddr + TYPE_FIELD_BITPOS (type, i) / 8,\r
+ address + TYPE_FIELD_BITPOS (type, i) / 8, 0,\r
+ stream, format, 0, recurse + 1, pretty); */\r
+ val_print (TYPE_FIELD_TYPE (type, i),\r
+ valaddr, TYPE_FIELD_BITPOS (type, i) / 8,\r
+ address + TYPE_FIELD_BITPOS (type, i) / 8,\r
+ stream, format, 0, recurse + 1, pretty);\r
+ }\r
+ }\r
+ annotate_field_end ();\r
+ }\r
+\r
+ if (dont_print_statmem == 0)\r
+ {\r
+ /* Free the space used to deal with the printing\r
+ of the members from top level. */\r
+ obstack_free (&dont_print_statmem_obstack, last_dont_print);\r
+ dont_print_statmem_obstack = tmp_obstack;\r
+ }\r
+\r
+ if (pretty)\r
+ {\r
+ fprintf_filtered (stream, "\n");\r
+ print_spaces_filtered (2 * recurse, stream);\r
+ }\r
+ }\r
+ fprintf_filtered (stream, "}");\r
+}\r
+\r
+/* Special val_print routine to avoid printing multiple copies of virtual\r
+ baseclasses. */\r
+\r
+void\r
+pascal_object_print_value (struct type *type, char *valaddr, CORE_ADDR address,\r
+ struct ui_file *stream, int format, int recurse,\r
+ enum val_prettyprint pretty,\r
+ struct type **dont_print_vb)\r
+{\r
+ struct obstack tmp_obstack;\r
+ struct type **last_dont_print\r
+ = (struct type **) obstack_next_free (&dont_print_vb_obstack);\r
+ int i, n_baseclasses = TYPE_N_BASECLASSES (type);\r
+\r
+ if (dont_print_vb == 0)\r
+ {\r
+ /* If we're at top level, carve out a completely fresh\r
+ chunk of the obstack and use that until this particular\r
+ invocation returns. */\r
+ tmp_obstack = dont_print_vb_obstack;\r
+ /* Bump up the high-water mark. Now alpha is omega. */\r
+ obstack_finish (&dont_print_vb_obstack);\r
+ }\r
+\r
+ for (i = 0; i < n_baseclasses; i++)\r
+ {\r
+ int boffset;\r
+ struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));\r
+ char *basename = TYPE_NAME (baseclass);\r
+ char *base_valaddr;\r
+\r
+ if (BASETYPE_VIA_VIRTUAL (type, i))\r
+ {\r
+ struct type **first_dont_print\r
+ = (struct type **) obstack_base (&dont_print_vb_obstack);\r
+\r
+ int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)\r
+ - first_dont_print;\r
+\r
+ while (--j >= 0)\r
+ if (baseclass == first_dont_print[j])\r
+ goto flush_it;\r
+\r
+ obstack_ptr_grow (&dont_print_vb_obstack, baseclass);\r
+ }\r
+\r
+ boffset = baseclass_offset (type, i, valaddr, address);\r
+\r
+ if (pretty)\r
+ {\r
+ fprintf_filtered (stream, "\n");\r
+ print_spaces_filtered (2 * recurse, stream);\r
+ }\r
+ fputs_filtered ("<", stream);\r
+ /* Not sure what the best notation is in the case where there is no\r
+ baseclass name. */\r
+\r
+ fputs_filtered (basename ? basename : "", stream);\r
+ fputs_filtered ("> = ", stream);\r
+\r
+ /* The virtual base class pointer might have been clobbered by the\r
+ user program. Make sure that it still points to a valid memory\r
+ location. */\r
+\r
+ if (boffset != -1 && (boffset < 0 || boffset >= TYPE_LENGTH (type)))\r
+ {\r
+ base_valaddr = (char *) alloca (TYPE_LENGTH (baseclass));\r
+ if (target_read_memory (address + boffset, base_valaddr,\r
+ TYPE_LENGTH (baseclass)) != 0)\r
+ boffset = -1;\r
+ }\r
+ else\r
+ base_valaddr = valaddr + boffset;\r
+\r
+ if (boffset == -1)\r
+ fprintf_filtered (stream, "<invalid address>");\r
+ else\r
+ pascal_object_print_value_fields (baseclass, base_valaddr, address + boffset,\r
+ stream, format, recurse, pretty,\r
+ (struct type **) obstack_base (&dont_print_vb_obstack),\r
+ 0);\r
+ fputs_filtered (", ", stream);\r
+\r
+ flush_it:\r
+ ;\r
+ }\r
+\r
+ if (dont_print_vb == 0)\r
+ {\r
+ /* Free the space used to deal with the printing\r
+ of this type from top level. */\r
+ obstack_free (&dont_print_vb_obstack, last_dont_print);\r
+ /* Reset watermark so that we can continue protecting\r
+ ourselves from whatever we were protecting ourselves. */\r
+ dont_print_vb_obstack = tmp_obstack;\r
+ }\r
+}\r
+\r
+/* Print value of a static member.\r
+ To avoid infinite recursion when printing a class that contains\r
+ a static instance of the class, we keep the addresses of all printed\r
+ static member classes in an obstack and refuse to print them more\r
+ than once.\r
+\r
+ VAL contains the value to print, TYPE, STREAM, RECURSE, and PRETTY\r
+ have the same meanings as in c_val_print. */\r
+\r
+static void\r
+pascal_object_print_static_field (struct type *type, value_ptr val,\r
+ struct ui_file *stream, int format,\r
+ int recurse, enum val_prettyprint pretty)\r
+{\r
+ if (TYPE_CODE (type) == TYPE_CODE_STRUCT)\r
+ {\r
+ CORE_ADDR *first_dont_print;\r
+ int i;\r
+\r
+ first_dont_print\r
+ = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);\r
+ i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)\r
+ - first_dont_print;\r
+\r
+ while (--i >= 0)\r
+ {\r
+ if (VALUE_ADDRESS (val) == first_dont_print[i])\r
+ {\r
+ fputs_filtered ("<same as static member of an already seen type>",\r
+ stream);\r
+ return;\r
+ }\r
+ }\r
+\r
+ obstack_grow (&dont_print_statmem_obstack, (char *) &VALUE_ADDRESS (val),\r
+ sizeof (CORE_ADDR));\r
+\r
+ CHECK_TYPEDEF (type);\r
+ pascal_object_print_value_fields (type, VALUE_CONTENTS (val), VALUE_ADDRESS (val),\r
+ stream, format, recurse, pretty, NULL, 1);\r
+ return;\r
+ }\r
+ val_print (type, VALUE_CONTENTS (val), 0, VALUE_ADDRESS (val),\r
+ stream, format, 0, recurse, pretty);\r
+}\r
+\r
+void\r
+pascal_object_print_class_member (char *valaddr, struct type *domain,\r
+ struct ui_file *stream, char *prefix)\r
+{\r
+\r
+ /* VAL is a byte offset into the structure type DOMAIN.\r
+ Find the name of the field for that offset and\r
+ print it. */\r
+ int extra = 0;\r
+ int bits = 0;\r
+ register unsigned int i;\r
+ unsigned len = TYPE_NFIELDS (domain);\r
+ /* @@ Make VAL into bit offset */\r
+ LONGEST val = unpack_long (builtin_type_int, valaddr) << 3;\r
+ for (i = TYPE_N_BASECLASSES (domain); i < len; i++)\r
+ {\r
+ int bitpos = TYPE_FIELD_BITPOS (domain, i);\r
+ QUIT;\r
+ if (val == bitpos)\r
+ break;\r
+ if (val < bitpos && i != 0)\r
+ {\r
+ /* Somehow pointing into a field. */\r
+ i -= 1;\r
+ extra = (val - TYPE_FIELD_BITPOS (domain, i));\r
+ if (extra & 0x7)\r
+ bits = 1;\r
+ else\r
+ extra >>= 3;\r
+ break;\r
+ }\r
+ }\r
+ if (i < len)\r
+ {\r
+ char *name;\r
+ fprintf_filtered (stream, prefix);\r
+ name = type_name_no_tag (domain);\r
+ if (name)\r
+ fputs_filtered (name, stream);\r
+ else\r
+ pascal_type_print_base (domain, stream, 0, 0);\r
+ fprintf_filtered (stream, "::");\r
+ fputs_filtered (TYPE_FIELD_NAME (domain, i), stream);\r
+ if (extra)\r
+ fprintf_filtered (stream, " + %d bytes", extra);\r
+ if (bits)\r
+ fprintf_filtered (stream, " (offset in bits)");\r
+ }\r
+ else\r
+ fprintf_filtered (stream, "%ld", (long int) (val >> 3));\r
+}\r
+\r
+\r
+void\r
+_initialize_pascal_valprint (void)\r
+{\r
+ add_show_from_set\r
+ (add_set_cmd ("pascal_static-members", class_support, var_boolean,\r
+ (char *) &pascal_static_field_print,\r
+ "Set printing of pascal static members.",\r
+ &setprintlist),\r
+ &showprintlist);\r
+ /* Turn on printing of static fields. */\r
+ pascal_static_field_print = 1;\r
+\r
+}\r
projects / thirdparty / binutils-gdb.git / commitdiff
