4b187201bc96cda32da91091e46d7db1c237a58a
[external/binutils.git] / gdb / p-lang.c
1 /* Pascal language support routines for GDB, the GNU debugger.
2
3    Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007
4    Free Software Foundation, Inc.
5
6    This file is part of GDB.
7
8    This program is free software; you can redistribute it and/or modify
9    it under the terms of the GNU General Public License as published by
10    the Free Software Foundation; either version 3 of the License, or
11    (at your option) any later version.
12
13    This program is distributed in the hope that it will be useful,
14    but WITHOUT ANY WARRANTY; without even the implied warranty of
15    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16    GNU General Public License for more details.
17
18    You should have received a copy of the GNU General Public License
19    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
20
21 /* This file is derived from c-lang.c */
22
23 #include "defs.h"
24 #include "gdb_string.h"
25 #include "symtab.h"
26 #include "gdbtypes.h"
27 #include "expression.h"
28 #include "parser-defs.h"
29 #include "language.h"
30 #include "p-lang.h"
31 #include "valprint.h"
32 #include "value.h"
33 #include <ctype.h>
34  
35 extern void _initialize_pascal_language (void);
36
37
38 /* All GPC versions until now (2007-09-27) also define a symbol called
39    '_p_initialize'. Check for the presence of this symbol first.  */
40 static const char GPC_P_INITIALIZE[] = "_p_initialize";
41
42 /* The name of the symbol that GPC uses as the name of the main
43    procedure (since version 20050212).  */
44 static const char GPC_MAIN_PROGRAM_NAME_1[] = "_p__M0_main_program";
45
46 /* Older versions of GPC (versions older than 20050212) were using
47    a different name for the main procedure.  */
48 static const char GPC_MAIN_PROGRAM_NAME_2[] = "pascal_main_program";
49
50 /* Function returning the special symbol name used
51    by GPC for the main procedure in the main program
52    if it is found in minimal symbol list.
53    This function tries to find minimal symbols generated by GPC
54    so that it finds the even if the program was compiled
55    without debugging information.
56    According to information supplied by Waldeck Hebisch,
57    this should work for all versions posterior to June 2000. */
58
59 const char *
60 pascal_main_name (void)
61 {
62   struct minimal_symbol *msym;
63
64   msym = lookup_minimal_symbol (GPC_P_INITIALIZE, NULL, NULL);
65
66   /*  If '_p_initialize' was not found, the main program is likely not
67      written in Pascal.  */
68   if (msym == NULL)
69     return NULL;
70
71   msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1, NULL, NULL);
72   if (msym != NULL)
73     {
74       return GPC_MAIN_PROGRAM_NAME_1;
75     }
76
77   msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2, NULL, NULL);
78   if (msym != NULL)
79     {
80       return GPC_MAIN_PROGRAM_NAME_2;
81     }
82
83   /*  No known entry procedure found, the main program is probably
84       not compiled with GPC.  */
85   return NULL;
86 }
87
88 /* Determines if type TYPE is a pascal string type.
89    Returns 1 if the type is a known pascal type
90    This function is used by p-valprint.c code to allow better string display.
91    If it is a pascal string type, then it also sets info needed
92    to get the length and the data of the string
93    length_pos, length_size and string_pos are given in bytes.
94    char_size gives the element size in bytes.
95    FIXME: if the position or the size of these fields
96    are not multiple of TARGET_CHAR_BIT then the results are wrong
97    but this does not happen for Free Pascal nor for GPC.  */
98 int
99 is_pascal_string_type (struct type *type,int *length_pos,
100                        int *length_size, int *string_pos, int *char_size,
101                        char **arrayname)
102 {
103   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
104     {
105       /* Old Borland type pascal strings from Free Pascal Compiler.  */
106       /* Two fields: length and st.  */
107       if (TYPE_NFIELDS (type) == 2 
108           && strcmp (TYPE_FIELDS (type)[0].name, "length") == 0 
109           && strcmp (TYPE_FIELDS (type)[1].name, "st") == 0)
110         {
111           if (length_pos)
112             *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT;
113           if (length_size)
114             *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
115           if (string_pos)
116             *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
117           if (char_size)
118             *char_size = 1;
119           if (arrayname)
120             *arrayname = TYPE_FIELDS (type)[1].name;
121          return 2;
122         };
123       /* GNU pascal strings.  */
124       /* Three fields: Capacity, length and schema$ or _p_schema.  */
125       if (TYPE_NFIELDS (type) == 3
126           && strcmp (TYPE_FIELDS (type)[0].name, "Capacity") == 0
127           && strcmp (TYPE_FIELDS (type)[1].name, "length") == 0)
128         {
129           if (length_pos)
130             *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
131           if (length_size)
132             *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 1));
133           if (string_pos)
134             *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT;
135           /* FIXME: how can I detect wide chars in GPC ?? */
136           if (char_size)
137             *char_size = 1;
138           if (arrayname)
139             *arrayname = TYPE_FIELDS (type)[2].name;
140          return 3;
141         };
142     }
143   return 0;
144 }
145
146 static void pascal_one_char (int, struct ui_file *, int *);
147
148 /* Print the character C on STREAM as part of the contents of a literal
149    string.
150    In_quotes is reset to 0 if a char is written with #4 notation */
151
152 static void
153 pascal_one_char (int c, struct ui_file *stream, int *in_quotes)
154 {
155
156   c &= 0xFF;                    /* Avoid sign bit follies */
157
158   if ((c == '\'') || (PRINT_LITERAL_FORM (c)))
159     {
160       if (!(*in_quotes))
161         fputs_filtered ("'", stream);
162       *in_quotes = 1;
163       if (c == '\'')
164         {
165           fputs_filtered ("''", stream);
166         }
167       else
168         fprintf_filtered (stream, "%c", c);
169     }
170   else
171     {
172       if (*in_quotes)
173         fputs_filtered ("'", stream);
174       *in_quotes = 0;
175       fprintf_filtered (stream, "#%d", (unsigned int) c);
176     }
177 }
178
179 static void pascal_emit_char (int c, struct ui_file *stream, int quoter);
180
181 /* Print the character C on STREAM as part of the contents of a literal
182    string whose delimiter is QUOTER.  Note that that format for printing
183    characters and strings is language specific. */
184
185 static void
186 pascal_emit_char (int c, struct ui_file *stream, int quoter)
187 {
188   int in_quotes = 0;
189   pascal_one_char (c, stream, &in_quotes);
190   if (in_quotes)
191     fputs_filtered ("'", stream);
192 }
193
194 void
195 pascal_printchar (int c, struct ui_file *stream)
196 {
197   int in_quotes = 0;
198   pascal_one_char (c, stream, &in_quotes);
199   if (in_quotes)
200     fputs_filtered ("'", stream);
201 }
202
203 /* Print the character string STRING, printing at most LENGTH characters.
204    Printing stops early if the number hits print_max; repeat counts
205    are printed as appropriate.  Print ellipses at the end if we
206    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.  */
207
208 void
209 pascal_printstr (struct ui_file *stream, const gdb_byte *string,
210                  unsigned int length, int width, int force_ellipses)
211 {
212   unsigned int i;
213   unsigned int things_printed = 0;
214   int in_quotes = 0;
215   int need_comma = 0;
216
217   /* If the string was not truncated due to `set print elements', and
218      the last byte of it is a null, we don't print that, in traditional C
219      style.  */
220   if ((!force_ellipses) && length > 0 && string[length - 1] == '\0')
221     length--;
222
223   if (length == 0)
224     {
225       fputs_filtered ("''", stream);
226       return;
227     }
228
229   for (i = 0; i < length && things_printed < print_max; ++i)
230     {
231       /* Position of the character we are examining
232          to see whether it is repeated.  */
233       unsigned int rep1;
234       /* Number of repetitions we have detected so far.  */
235       unsigned int reps;
236
237       QUIT;
238
239       if (need_comma)
240         {
241           fputs_filtered (", ", stream);
242           need_comma = 0;
243         }
244
245       rep1 = i + 1;
246       reps = 1;
247       while (rep1 < length && string[rep1] == string[i])
248         {
249           ++rep1;
250           ++reps;
251         }
252
253       if (reps > repeat_count_threshold)
254         {
255           if (in_quotes)
256             {
257               if (inspect_it)
258                 fputs_filtered ("\\', ", stream);
259               else
260                 fputs_filtered ("', ", stream);
261               in_quotes = 0;
262             }
263           pascal_printchar (string[i], stream);
264           fprintf_filtered (stream, " <repeats %u times>", reps);
265           i = rep1 - 1;
266           things_printed += repeat_count_threshold;
267           need_comma = 1;
268         }
269       else
270         {
271           int c = string[i];
272           if ((!in_quotes) && (PRINT_LITERAL_FORM (c)))
273             {
274               if (inspect_it)
275                 fputs_filtered ("\\'", stream);
276               else
277                 fputs_filtered ("'", stream);
278               in_quotes = 1;
279             }
280           pascal_one_char (c, stream, &in_quotes);
281           ++things_printed;
282         }
283     }
284
285   /* Terminate the quotes if necessary.  */
286   if (in_quotes)
287     {
288       if (inspect_it)
289         fputs_filtered ("\\'", stream);
290       else
291         fputs_filtered ("'", stream);
292     }
293
294   if (force_ellipses || i < length)
295     fputs_filtered ("...", stream);
296 }
297
298 /* Create a fundamental Pascal type using default reasonable for the current
299    target machine.
300
301    Some object/debugging file formats (DWARF version 1, COFF, etc) do not
302    define fundamental types such as "int" or "double".  Others (stabs or
303    DWARF version 2, etc) do define fundamental types.  For the formats which
304    don't provide fundamental types, gdb can create such types using this
305    function.
306
307    FIXME:  Some compilers distinguish explicitly signed integral types
308    (signed short, signed int, signed long) from "regular" integral types
309    (short, int, long) in the debugging information.  There is some dis-
310    agreement as to how useful this feature is.  In particular, gcc does
311    not support this.  Also, only some debugging formats allow the
312    distinction to be passed on to a debugger.  For now, we always just
313    use "short", "int", or "long" as the type name, for both the implicit
314    and explicitly signed types.  This also makes life easier for the
315    gdb test suite since we don't have to account for the differences
316    in output depending upon what the compiler and debugging format
317    support.  We will probably have to re-examine the issue when gdb
318    starts taking it's fundamental type information directly from the
319    debugging information supplied by the compiler.  fnf@cygnus.com */
320
321 /* Note there might be some discussion about the choosen correspondance
322    because it mainly reflects Free Pascal Compiler setup for now PM */
323
324
325 struct type *
326 pascal_create_fundamental_type (struct objfile *objfile, int typeid)
327 {
328   struct type *type = NULL;
329
330   switch (typeid)
331     {
332     default:
333       /* FIXME:  For now, if we are asked to produce a type not in this
334          language, create the equivalent of a C integer type with the
335          name "<?type?>".  When all the dust settles from the type
336          reconstruction work, this should probably become an error. */
337       type = init_type (TYPE_CODE_INT,
338                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
339                         0, "<?type?>", objfile);
340       warning (_("internal error: no Pascal fundamental type %d"), typeid);
341       break;
342     case FT_VOID:
343       type = init_type (TYPE_CODE_VOID,
344                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
345                         0, "void", objfile);
346       break;
347     case FT_CHAR:
348       type = init_type (TYPE_CODE_CHAR,
349                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
350                         0, "char", objfile);
351       break;
352     case FT_SIGNED_CHAR:
353       type = init_type (TYPE_CODE_INT,
354                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
355                         0, "shortint", objfile);
356       break;
357     case FT_UNSIGNED_CHAR:
358       type = init_type (TYPE_CODE_INT,
359                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
360                         TYPE_FLAG_UNSIGNED, "byte", objfile);
361       break;
362     case FT_SHORT:
363       type = init_type (TYPE_CODE_INT,
364                         gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
365                         0, "integer", objfile);
366       break;
367     case FT_SIGNED_SHORT:
368       type = init_type (TYPE_CODE_INT,
369                         gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
370                         0, "integer", objfile);         /* FIXME-fnf */
371       break;
372     case FT_UNSIGNED_SHORT:
373       type = init_type (TYPE_CODE_INT,
374                         gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
375                         TYPE_FLAG_UNSIGNED, "word", objfile);
376       break;
377     case FT_INTEGER:
378       type = init_type (TYPE_CODE_INT,
379                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
380                         0, "longint", objfile);
381       break;
382     case FT_SIGNED_INTEGER:
383       type = init_type (TYPE_CODE_INT,
384                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
385                         0, "longint", objfile);         /* FIXME -fnf */
386       break;
387     case FT_UNSIGNED_INTEGER:
388       type = init_type (TYPE_CODE_INT,
389                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
390                         TYPE_FLAG_UNSIGNED, "cardinal", objfile);
391       break;
392     case FT_LONG:
393       type = init_type (TYPE_CODE_INT,
394                         gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
395                         0, "long", objfile);
396       break;
397     case FT_SIGNED_LONG:
398       type = init_type (TYPE_CODE_INT,
399                         gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
400                         0, "long", objfile);    /* FIXME -fnf */
401       break;
402     case FT_UNSIGNED_LONG:
403       type = init_type (TYPE_CODE_INT,
404                         gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
405                         TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
406       break;
407     case FT_LONG_LONG:
408       type = init_type (TYPE_CODE_INT,
409                         gdbarch_long_long_bit
410                           (current_gdbarch) / TARGET_CHAR_BIT,
411                         0, "long long", objfile);
412       break;
413     case FT_SIGNED_LONG_LONG:
414       type = init_type (TYPE_CODE_INT,
415                         gdbarch_long_long_bit
416                           (current_gdbarch) / TARGET_CHAR_BIT,
417                         0, "signed long long", objfile);
418       break;
419     case FT_UNSIGNED_LONG_LONG:
420       type = init_type (TYPE_CODE_INT,
421                         gdbarch_long_long_bit
422                           (current_gdbarch) / TARGET_CHAR_BIT,
423                         TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
424       break;
425     case FT_FLOAT:
426       type = init_type (TYPE_CODE_FLT,
427                         gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
428                         0, "float", objfile);
429       break;
430     case FT_DBL_PREC_FLOAT:
431       type = init_type (TYPE_CODE_FLT,
432                         gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
433                         0, "double", objfile);
434       break;
435     case FT_EXT_PREC_FLOAT:
436       type = init_type (TYPE_CODE_FLT,
437                         gdbarch_long_double_bit (current_gdbarch)
438                           / TARGET_CHAR_BIT,
439                         0, "extended", objfile);
440       break;
441     }
442   return (type);
443 }
444 \f
445
446 /* Table mapping opcodes into strings for printing operators
447    and precedences of the operators.  */
448
449 const struct op_print pascal_op_print_tab[] =
450 {
451   {",", BINOP_COMMA, PREC_COMMA, 0},
452   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
453   {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
454   {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
455   {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
456   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
457   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
458   {"<=", BINOP_LEQ, PREC_ORDER, 0},
459   {">=", BINOP_GEQ, PREC_ORDER, 0},
460   {">", BINOP_GTR, PREC_ORDER, 0},
461   {"<", BINOP_LESS, PREC_ORDER, 0},
462   {"shr", BINOP_RSH, PREC_SHIFT, 0},
463   {"shl", BINOP_LSH, PREC_SHIFT, 0},
464   {"+", BINOP_ADD, PREC_ADD, 0},
465   {"-", BINOP_SUB, PREC_ADD, 0},
466   {"*", BINOP_MUL, PREC_MUL, 0},
467   {"/", BINOP_DIV, PREC_MUL, 0},
468   {"div", BINOP_INTDIV, PREC_MUL, 0},
469   {"mod", BINOP_REM, PREC_MUL, 0},
470   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
471   {"-", UNOP_NEG, PREC_PREFIX, 0},
472   {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
473   {"^", UNOP_IND, PREC_SUFFIX, 1},
474   {"@", UNOP_ADDR, PREC_PREFIX, 0},
475   {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
476   {NULL, 0, 0, 0}
477 };
478 \f
479 enum pascal_primitive_types {
480   pascal_primitive_type_int,
481   pascal_primitive_type_long,
482   pascal_primitive_type_short,
483   pascal_primitive_type_char,
484   pascal_primitive_type_float,
485   pascal_primitive_type_double,
486   pascal_primitive_type_void,
487   pascal_primitive_type_long_long,
488   pascal_primitive_type_signed_char,
489   pascal_primitive_type_unsigned_char,
490   pascal_primitive_type_unsigned_short,
491   pascal_primitive_type_unsigned_int,
492   pascal_primitive_type_unsigned_long,
493   pascal_primitive_type_unsigned_long_long,
494   pascal_primitive_type_long_double,
495   pascal_primitive_type_complex,
496   pascal_primitive_type_double_complex,
497   nr_pascal_primitive_types
498 };
499
500 static void
501 pascal_language_arch_info (struct gdbarch *gdbarch,
502                            struct language_arch_info *lai)
503 {
504   const struct builtin_type *builtin = builtin_type (gdbarch);
505   lai->string_char_type = builtin->builtin_char;
506   lai->primitive_type_vector
507     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
508                               struct type *);
509   lai->primitive_type_vector [pascal_primitive_type_int]
510     = builtin->builtin_int;
511   lai->primitive_type_vector [pascal_primitive_type_long]
512     = builtin->builtin_long;
513   lai->primitive_type_vector [pascal_primitive_type_short]
514     = builtin->builtin_short;
515   lai->primitive_type_vector [pascal_primitive_type_char]
516     = builtin->builtin_char;
517   lai->primitive_type_vector [pascal_primitive_type_float]
518     = builtin->builtin_float;
519   lai->primitive_type_vector [pascal_primitive_type_double]
520     = builtin->builtin_double;
521   lai->primitive_type_vector [pascal_primitive_type_void]
522     = builtin->builtin_void;
523   lai->primitive_type_vector [pascal_primitive_type_long_long]
524     = builtin->builtin_long_long;
525   lai->primitive_type_vector [pascal_primitive_type_signed_char]
526     = builtin->builtin_signed_char;
527   lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
528     = builtin->builtin_unsigned_char;
529   lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
530     = builtin->builtin_unsigned_short;
531   lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
532     = builtin->builtin_unsigned_int;
533   lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
534     = builtin->builtin_unsigned_long;
535   lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
536     = builtin->builtin_unsigned_long_long;
537   lai->primitive_type_vector [pascal_primitive_type_long_double]
538     = builtin->builtin_long_double;
539   lai->primitive_type_vector [pascal_primitive_type_complex]
540     = builtin->builtin_complex;
541   lai->primitive_type_vector [pascal_primitive_type_double_complex]
542     = builtin->builtin_double_complex;
543 }
544
545 const struct language_defn pascal_language_defn =
546 {
547   "pascal",                     /* Language name */
548   language_pascal,
549   NULL,
550   range_check_on,
551   type_check_on,
552   case_sensitive_on,
553   array_row_major,
554   &exp_descriptor_standard,
555   pascal_parse,
556   pascal_error,
557   null_post_parser,
558   pascal_printchar,             /* Print a character constant */
559   pascal_printstr,              /* Function to print string constant */
560   pascal_emit_char,             /* Print a single char */
561   pascal_create_fundamental_type,       /* Create fundamental type in this language */
562   pascal_print_type,            /* Print a type using appropriate syntax */
563   pascal_val_print,             /* Print a value using appropriate syntax */
564   pascal_value_print,           /* Print a top-level value */
565   NULL,                         /* Language specific skip_trampoline */
566   value_of_this,                /* value_of_this */
567   basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
568   basic_lookup_transparent_type,/* lookup_transparent_type */
569   NULL,                         /* Language specific symbol demangler */
570   NULL,                         /* Language specific class_name_from_physname */
571   pascal_op_print_tab,          /* expression operators for printing */
572   1,                            /* c-style arrays */
573   0,                            /* String lower bound */
574   NULL,
575   default_word_break_characters,
576   pascal_language_arch_info,
577   default_print_array_index,
578   default_pass_by_reference,
579   LANG_MAGIC
580 };
581
582 void
583 _initialize_pascal_language (void)
584 {
585   add_language (&pascal_language_defn);
586 }