1/* YACC parser for Pascal expressions, for GDB.
2   Copyright (C) 2000-2020 Free Software Foundation, Inc.
3
4   This file is part of GDB.
5
6   This program is free software; you can redistribute it and/or modify
7   it under the terms of the GNU General Public License as published by
8   the Free Software Foundation; either version 3 of the License, or
9   (at your option) any later version.
10
11   This program is distributed in the hope that it will be useful,
12   but WITHOUT ANY WARRANTY; without even the implied warranty of
13   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14   GNU General Public License for more details.
15
16   You should have received a copy of the GNU General Public License
17   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
18
19/* This file is derived from c-exp.y */
20
21/* Parse a Pascal expression from text in a string,
22   and return the result as a  struct expression  pointer.
23   That structure contains arithmetic operations in reverse polish,
24   with constants represented by operations that are followed by special data.
25   See expression.h for the details of the format.
26   What is important here is that it can be built up sequentially
27   during the process of parsing; the lower levels of the tree always
28   come first in the result.
29
30   Note that malloc's and realloc's in this file are transformed to
31   xmalloc and xrealloc respectively by the same sed command in the
32   makefile that remaps any other malloc/realloc inserted by the parser
33   generator.  Doing this with #defines and trying to control the interaction
34   with include files (<malloc.h> and <stdlib.h> for example) just became
35   too messy, particularly when such includes can be inserted at random
36   times by the parser generator.  */
37
38/* Known bugs or limitations:
39    - pascal string operations are not supported at all.
40    - there are some problems with boolean types.
41    - Pascal type hexadecimal constants are not supported
42      because they conflict with the internal variables format.
43   Probably also lots of other problems, less well defined PM.  */
44%{
45
46#include "defs.h"
47#include <ctype.h>
48#include "expression.h"
49#include "value.h"
50#include "parser-defs.h"
51#include "language.h"
52#include "p-lang.h"
53#include "bfd.h" /* Required by objfiles.h.  */
54#include "symfile.h" /* Required by objfiles.h.  */
55#include "objfiles.h" /* For have_full_symbols and have_partial_symbols.  */
56#include "block.h"
57#include "completer.h"
58
59#define parse_type(ps) builtin_type (ps->gdbarch ())
60
61/* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
62   etc).  */
63#define GDB_YY_REMAP_PREFIX pascal_
64#include "yy-remap.h"
65
66/* The state of the parser, used internally when we are parsing the
67   expression.  */
68
69static struct parser_state *pstate = NULL;
70
71/* Depth of parentheses.  */
72static int paren_depth;
73
74int yyparse (void);
75
76static int yylex (void);
77
78static void yyerror (const char *);
79
80static char *uptok (const char *, int);
81%}
82
83/* Although the yacc "value" of an expression is not used,
84   since the result is stored in the structure being created,
85   other node types do have values.  */
86
87%union
88  {
89    LONGEST lval;
90    struct {
91      LONGEST val;
92      struct type *type;
93    } typed_val_int;
94    struct {
95      gdb_byte val[16];
96      struct type *type;
97    } typed_val_float;
98    struct symbol *sym;
99    struct type *tval;
100    struct stoken sval;
101    struct ttype tsym;
102    struct symtoken ssym;
103    int voidval;
104    const struct block *bval;
105    enum exp_opcode opcode;
106    struct internalvar *ivar;
107
108    struct type **tvec;
109    int *ivec;
110  }
111
112%{
113/* YYSTYPE gets defined by %union */
114static int parse_number (struct parser_state *,
115			 const char *, int, int, YYSTYPE *);
116
117static struct type *current_type;
118static struct internalvar *intvar;
119static int leftdiv_is_integer;
120static void push_current_type (void);
121static void pop_current_type (void);
122static int search_field;
123%}
124
125%type <voidval> exp exp1 type_exp start normal_start variable qualified_name
126%type <tval> type typebase
127/* %type <bval> block */
128
129/* Fancy type parsing.  */
130%type <tval> ptype
131
132%token <typed_val_int> INT
133%token <typed_val_float> FLOAT
134
135/* Both NAME and TYPENAME tokens represent symbols in the input,
136   and both convey their data as strings.
137   But a TYPENAME is a string that happens to be defined as a typedef
138   or builtin type name (such as int or char)
139   and a NAME is any other symbol.
140   Contexts where this distinction is not important can use the
141   nonterminal "name", which matches either NAME or TYPENAME.  */
142
143%token <sval> STRING
144%token <sval> FIELDNAME
145%token <voidval> COMPLETE
146%token <ssym> NAME /* BLOCKNAME defined below to give it higher precedence.  */
147%token <tsym> TYPENAME
148%type <sval> name
149%type <ssym> name_not_typename
150
151/* A NAME_OR_INT is a symbol which is not known in the symbol table,
152   but which would parse as a valid number in the current input radix.
153   E.g. "c" when input_radix==16.  Depending on the parse, it will be
154   turned into a name or into a number.  */
155
156%token <ssym> NAME_OR_INT
157
158%token STRUCT CLASS SIZEOF COLONCOLON
159%token ERROR
160
161/* Special type cases, put in to allow the parser to distinguish different
162   legal basetypes.  */
163
164%token <voidval> DOLLAR_VARIABLE
165
166
167/* Object pascal */
168%token THIS
169%token <lval> TRUEKEYWORD FALSEKEYWORD
170
171%left ','
172%left ABOVE_COMMA
173%right ASSIGN
174%left NOT
175%left OR
176%left XOR
177%left ANDAND
178%left '=' NOTEQUAL
179%left '<' '>' LEQ GEQ
180%left LSH RSH DIV MOD
181%left '@'
182%left '+' '-'
183%left '*' '/'
184%right UNARY INCREMENT DECREMENT
185%right ARROW '.' '[' '('
186%left '^'
187%token <ssym> BLOCKNAME
188%type <bval> block
189%left COLONCOLON
190
191
192%%
193
194start   :	{ current_type = NULL;
195		  intvar = NULL;
196		  search_field = 0;
197		  leftdiv_is_integer = 0;
198		}
199		normal_start {}
200	;
201
202normal_start	:
203		exp1
204	|	type_exp
205	;
206
207type_exp:	type
208			{ write_exp_elt_opcode (pstate, OP_TYPE);
209			  write_exp_elt_type (pstate, $1);
210			  write_exp_elt_opcode (pstate, OP_TYPE);
211			  current_type = $1; } ;
212
213/* Expressions, including the comma operator.  */
214exp1	:	exp
215	|	exp1 ',' exp
216			{ write_exp_elt_opcode (pstate, BINOP_COMMA); }
217	;
218
219/* Expressions, not including the comma operator.  */
220exp	:	exp '^'   %prec UNARY
221			{ write_exp_elt_opcode (pstate, UNOP_IND);
222			  if (current_type)
223			    current_type = TYPE_TARGET_TYPE (current_type); }
224	;
225
226exp	:	'@' exp    %prec UNARY
227			{ write_exp_elt_opcode (pstate, UNOP_ADDR);
228			  if (current_type)
229			    current_type = TYPE_POINTER_TYPE (current_type); }
230	;
231
232exp	:	'-' exp    %prec UNARY
233			{ write_exp_elt_opcode (pstate, UNOP_NEG); }
234	;
235
236exp	:	NOT exp    %prec UNARY
237			{ write_exp_elt_opcode (pstate, UNOP_LOGICAL_NOT); }
238	;
239
240exp	:	INCREMENT '(' exp ')'   %prec UNARY
241			{ write_exp_elt_opcode (pstate, UNOP_PREINCREMENT); }
242	;
243
244exp	:	DECREMENT  '(' exp ')'   %prec UNARY
245			{ write_exp_elt_opcode (pstate, UNOP_PREDECREMENT); }
246	;
247
248
249field_exp	:	exp '.'	%prec UNARY
250			{ search_field = 1; }
251	;
252
253exp	:	field_exp FIELDNAME
254			{ write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
255			  write_exp_string (pstate, $2);
256			  write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
257			  search_field = 0;
258			  if (current_type)
259			    {
260			      while (current_type->code ()
261				     == TYPE_CODE_PTR)
262				current_type =
263				  TYPE_TARGET_TYPE (current_type);
264			      current_type = lookup_struct_elt_type (
265				current_type, $2.ptr, 0);
266			    }
267			 }
268	;
269
270
271exp	:	field_exp name
272			{ write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
273			  write_exp_string (pstate, $2);
274			  write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
275			  search_field = 0;
276			  if (current_type)
277			    {
278			      while (current_type->code ()
279				     == TYPE_CODE_PTR)
280				current_type =
281				  TYPE_TARGET_TYPE (current_type);
282			      current_type = lookup_struct_elt_type (
283				current_type, $2.ptr, 0);
284			    }
285			}
286	;
287exp	:	field_exp  name COMPLETE
288			{ pstate->mark_struct_expression ();
289			  write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
290			  write_exp_string (pstate, $2);
291			  write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
292	;
293exp	:	field_exp COMPLETE
294			{ struct stoken s;
295			  pstate->mark_struct_expression ();
296			  write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
297			  s.ptr = "";
298			  s.length = 0;
299			  write_exp_string (pstate, s);
300			  write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
301	;
302
303exp	:	exp '['
304			/* We need to save the current_type value.  */
305			{ const char *arrayname;
306			  int arrayfieldindex;
307			  arrayfieldindex = is_pascal_string_type (
308				current_type, NULL, NULL,
309				NULL, NULL, &arrayname);
310			  if (arrayfieldindex)
311			    {
312			      struct stoken stringsval;
313			      char *buf;
314
315			      buf = (char *) alloca (strlen (arrayname) + 1);
316			      stringsval.ptr = buf;
317			      stringsval.length = strlen (arrayname);
318			      strcpy (buf, arrayname);
319			      current_type
320				= (current_type
321				   ->field (arrayfieldindex - 1).type ());
322			      write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
323			      write_exp_string (pstate, stringsval);
324			      write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
325			    }
326			  push_current_type ();  }
327		exp1 ']'
328			{ pop_current_type ();
329			  write_exp_elt_opcode (pstate, BINOP_SUBSCRIPT);
330			  if (current_type)
331			    current_type = TYPE_TARGET_TYPE (current_type); }
332	;
333
334exp	:	exp '('
335			/* This is to save the value of arglist_len
336			   being accumulated by an outer function call.  */
337			{ push_current_type ();
338			  pstate->start_arglist (); }
339		arglist ')'	%prec ARROW
340			{ write_exp_elt_opcode (pstate, OP_FUNCALL);
341			  write_exp_elt_longcst (pstate,
342						 pstate->end_arglist ());
343			  write_exp_elt_opcode (pstate, OP_FUNCALL);
344			  pop_current_type ();
345			  if (current_type)
346 	  		    current_type = TYPE_TARGET_TYPE (current_type);
347			}
348	;
349
350arglist	:
351         | exp
352			{ pstate->arglist_len = 1; }
353	 | arglist ',' exp   %prec ABOVE_COMMA
354			{ pstate->arglist_len++; }
355	;
356
357exp	:	type '(' exp ')' %prec UNARY
358			{ if (current_type)
359			    {
360			      /* Allow automatic dereference of classes.  */
361			      if ((current_type->code () == TYPE_CODE_PTR)
362				  && (TYPE_TARGET_TYPE (current_type)->code () == TYPE_CODE_STRUCT)
363				  && (($1)->code () == TYPE_CODE_STRUCT))
364				write_exp_elt_opcode (pstate, UNOP_IND);
365			    }
366			  write_exp_elt_opcode (pstate, UNOP_CAST);
367			  write_exp_elt_type (pstate, $1);
368			  write_exp_elt_opcode (pstate, UNOP_CAST);
369			  current_type = $1; }
370	;
371
372exp	:	'(' exp1 ')'
373			{ }
374	;
375
376/* Binary operators in order of decreasing precedence.  */
377
378exp	:	exp '*' exp
379			{ write_exp_elt_opcode (pstate, BINOP_MUL); }
380	;
381
382exp	:	exp '/' {
383			  if (current_type && is_integral_type (current_type))
384			    leftdiv_is_integer = 1;
385			}
386		exp
387			{
388			  if (leftdiv_is_integer && current_type
389			      && is_integral_type (current_type))
390			    {
391			      write_exp_elt_opcode (pstate, UNOP_CAST);
392			      write_exp_elt_type (pstate,
393						  parse_type (pstate)
394						  ->builtin_long_double);
395			      current_type
396				= parse_type (pstate)->builtin_long_double;
397			      write_exp_elt_opcode (pstate, UNOP_CAST);
398			      leftdiv_is_integer = 0;
399			    }
400
401			  write_exp_elt_opcode (pstate, BINOP_DIV);
402			}
403	;
404
405exp	:	exp DIV exp
406			{ write_exp_elt_opcode (pstate, BINOP_INTDIV); }
407	;
408
409exp	:	exp MOD exp
410			{ write_exp_elt_opcode (pstate, BINOP_REM); }
411	;
412
413exp	:	exp '+' exp
414			{ write_exp_elt_opcode (pstate, BINOP_ADD); }
415	;
416
417exp	:	exp '-' exp
418			{ write_exp_elt_opcode (pstate, BINOP_SUB); }
419	;
420
421exp	:	exp LSH exp
422			{ write_exp_elt_opcode (pstate, BINOP_LSH); }
423	;
424
425exp	:	exp RSH exp
426			{ write_exp_elt_opcode (pstate, BINOP_RSH); }
427	;
428
429exp	:	exp '=' exp
430			{ write_exp_elt_opcode (pstate, BINOP_EQUAL);
431			  current_type = parse_type (pstate)->builtin_bool;
432			}
433	;
434
435exp	:	exp NOTEQUAL exp
436			{ write_exp_elt_opcode (pstate, BINOP_NOTEQUAL);
437			  current_type = parse_type (pstate)->builtin_bool;
438			}
439	;
440
441exp	:	exp LEQ exp
442			{ write_exp_elt_opcode (pstate, BINOP_LEQ);
443			  current_type = parse_type (pstate)->builtin_bool;
444			}
445	;
446
447exp	:	exp GEQ exp
448			{ write_exp_elt_opcode (pstate, BINOP_GEQ);
449			  current_type = parse_type (pstate)->builtin_bool;
450			}
451	;
452
453exp	:	exp '<' exp
454			{ write_exp_elt_opcode (pstate, BINOP_LESS);
455			  current_type = parse_type (pstate)->builtin_bool;
456			}
457	;
458
459exp	:	exp '>' exp
460			{ write_exp_elt_opcode (pstate, BINOP_GTR);
461			  current_type = parse_type (pstate)->builtin_bool;
462			}
463	;
464
465exp	:	exp ANDAND exp
466			{ write_exp_elt_opcode (pstate, BINOP_BITWISE_AND); }
467	;
468
469exp	:	exp XOR exp
470			{ write_exp_elt_opcode (pstate, BINOP_BITWISE_XOR); }
471	;
472
473exp	:	exp OR exp
474			{ write_exp_elt_opcode (pstate, BINOP_BITWISE_IOR); }
475	;
476
477exp	:	exp ASSIGN exp
478			{ write_exp_elt_opcode (pstate, BINOP_ASSIGN); }
479	;
480
481exp	:	TRUEKEYWORD
482			{ write_exp_elt_opcode (pstate, OP_BOOL);
483			  write_exp_elt_longcst (pstate, (LONGEST) $1);
484			  current_type = parse_type (pstate)->builtin_bool;
485			  write_exp_elt_opcode (pstate, OP_BOOL); }
486	;
487
488exp	:	FALSEKEYWORD
489			{ write_exp_elt_opcode (pstate, OP_BOOL);
490			  write_exp_elt_longcst (pstate, (LONGEST) $1);
491			  current_type = parse_type (pstate)->builtin_bool;
492			  write_exp_elt_opcode (pstate, OP_BOOL); }
493	;
494
495exp	:	INT
496			{ write_exp_elt_opcode (pstate, OP_LONG);
497			  write_exp_elt_type (pstate, $1.type);
498			  current_type = $1.type;
499			  write_exp_elt_longcst (pstate, (LONGEST)($1.val));
500			  write_exp_elt_opcode (pstate, OP_LONG); }
501	;
502
503exp	:	NAME_OR_INT
504			{ YYSTYPE val;
505			  parse_number (pstate, $1.stoken.ptr,
506					$1.stoken.length, 0, &val);
507			  write_exp_elt_opcode (pstate, OP_LONG);
508			  write_exp_elt_type (pstate, val.typed_val_int.type);
509			  current_type = val.typed_val_int.type;
510			  write_exp_elt_longcst (pstate, (LONGEST)
511						 val.typed_val_int.val);
512			  write_exp_elt_opcode (pstate, OP_LONG);
513			}
514	;
515
516
517exp	:	FLOAT
518			{ write_exp_elt_opcode (pstate, OP_FLOAT);
519			  write_exp_elt_type (pstate, $1.type);
520			  current_type = $1.type;
521			  write_exp_elt_floatcst (pstate, $1.val);
522			  write_exp_elt_opcode (pstate, OP_FLOAT); }
523	;
524
525exp	:	variable
526	;
527
528exp	:	DOLLAR_VARIABLE
529			/* Already written by write_dollar_variable.
530			   Handle current_type.  */
531 			{  if (intvar) {
532 			     struct value * val, * mark;
533
534			     mark = value_mark ();
535 			     val = value_of_internalvar (pstate->gdbarch (),
536 							 intvar);
537 			     current_type = value_type (val);
538			     value_release_to_mark (mark);
539 			   }
540 			}
541 	;
542
543exp	:	SIZEOF '(' type ')'	%prec UNARY
544			{ write_exp_elt_opcode (pstate, OP_LONG);
545			  write_exp_elt_type (pstate,
546					    parse_type (pstate)->builtin_int);
547			  current_type = parse_type (pstate)->builtin_int;
548			  $3 = check_typedef ($3);
549			  write_exp_elt_longcst (pstate,
550						 (LONGEST) TYPE_LENGTH ($3));
551			  write_exp_elt_opcode (pstate, OP_LONG); }
552	;
553
554exp	:	SIZEOF  '(' exp ')'      %prec UNARY
555			{ write_exp_elt_opcode (pstate, UNOP_SIZEOF);
556			  current_type = parse_type (pstate)->builtin_int; }
557
558exp	:	STRING
559			{ /* C strings are converted into array constants with
560			     an explicit null byte added at the end.  Thus
561			     the array upper bound is the string length.
562			     There is no such thing in C as a completely empty
563			     string.  */
564			  const char *sp = $1.ptr; int count = $1.length;
565
566			  while (count-- > 0)
567			    {
568			      write_exp_elt_opcode (pstate, OP_LONG);
569			      write_exp_elt_type (pstate,
570						  parse_type (pstate)
571						  ->builtin_char);
572			      write_exp_elt_longcst (pstate,
573						     (LONGEST) (*sp++));
574			      write_exp_elt_opcode (pstate, OP_LONG);
575			    }
576			  write_exp_elt_opcode (pstate, OP_LONG);
577			  write_exp_elt_type (pstate,
578					      parse_type (pstate)
579					      ->builtin_char);
580			  write_exp_elt_longcst (pstate, (LONGEST)'\0');
581			  write_exp_elt_opcode (pstate, OP_LONG);
582			  write_exp_elt_opcode (pstate, OP_ARRAY);
583			  write_exp_elt_longcst (pstate, (LONGEST) 0);
584			  write_exp_elt_longcst (pstate,
585						 (LONGEST) ($1.length));
586			  write_exp_elt_opcode (pstate, OP_ARRAY); }
587	;
588
589/* Object pascal  */
590exp	:	THIS
591			{
592			  struct value * this_val;
593			  struct type * this_type;
594			  write_exp_elt_opcode (pstate, OP_THIS);
595			  write_exp_elt_opcode (pstate, OP_THIS);
596			  /* We need type of this.  */
597			  this_val
598			    = value_of_this_silent (pstate->language ());
599			  if (this_val)
600			    this_type = value_type (this_val);
601			  else
602			    this_type = NULL;
603			  if (this_type)
604			    {
605			      if (this_type->code () == TYPE_CODE_PTR)
606				{
607				  this_type = TYPE_TARGET_TYPE (this_type);
608				  write_exp_elt_opcode (pstate, UNOP_IND);
609				}
610			    }
611
612			  current_type = this_type;
613			}
614	;
615
616/* end of object pascal.  */
617
618block	:	BLOCKNAME
619			{
620			  if ($1.sym.symbol != 0)
621			      $$ = SYMBOL_BLOCK_VALUE ($1.sym.symbol);
622			  else
623			    {
624			      std::string copy = copy_name ($1.stoken);
625			      struct symtab *tem =
626				  lookup_symtab (copy.c_str ());
627			      if (tem)
628				$$ = BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (tem),
629							STATIC_BLOCK);
630			      else
631				error (_("No file or function \"%s\"."),
632				       copy.c_str ());
633			    }
634			}
635	;
636
637block	:	block COLONCOLON name
638			{
639			  std::string copy = copy_name ($3);
640			  struct symbol *tem
641			    = lookup_symbol (copy.c_str (), $1,
642					     VAR_DOMAIN, NULL).symbol;
643
644			  if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
645			    error (_("No function \"%s\" in specified context."),
646				   copy.c_str ());
647			  $$ = SYMBOL_BLOCK_VALUE (tem); }
648	;
649
650variable:	block COLONCOLON name
651			{ struct block_symbol sym;
652
653			  std::string copy = copy_name ($3);
654			  sym = lookup_symbol (copy.c_str (), $1,
655					       VAR_DOMAIN, NULL);
656			  if (sym.symbol == 0)
657			    error (_("No symbol \"%s\" in specified context."),
658				   copy.c_str ());
659
660			  write_exp_elt_opcode (pstate, OP_VAR_VALUE);
661			  write_exp_elt_block (pstate, sym.block);
662			  write_exp_elt_sym (pstate, sym.symbol);
663			  write_exp_elt_opcode (pstate, OP_VAR_VALUE); }
664	;
665
666qualified_name:	typebase COLONCOLON name
667			{
668			  struct type *type = $1;
669
670			  if (type->code () != TYPE_CODE_STRUCT
671			      && type->code () != TYPE_CODE_UNION)
672			    error (_("`%s' is not defined as an aggregate type."),
673				   type->name ());
674
675			  write_exp_elt_opcode (pstate, OP_SCOPE);
676			  write_exp_elt_type (pstate, type);
677			  write_exp_string (pstate, $3);
678			  write_exp_elt_opcode (pstate, OP_SCOPE);
679			}
680	;
681
682variable:	qualified_name
683	|	COLONCOLON name
684			{
685			  std::string name = copy_name ($2);
686			  struct symbol *sym;
687			  struct bound_minimal_symbol msymbol;
688
689			  sym =
690			    lookup_symbol (name.c_str (),
691					   (const struct block *) NULL,
692					   VAR_DOMAIN, NULL).symbol;
693			  if (sym)
694			    {
695			      write_exp_elt_opcode (pstate, OP_VAR_VALUE);
696			      write_exp_elt_block (pstate, NULL);
697			      write_exp_elt_sym (pstate, sym);
698			      write_exp_elt_opcode (pstate, OP_VAR_VALUE);
699			      break;
700			    }
701
702			  msymbol
703			    = lookup_bound_minimal_symbol (name.c_str ());
704			  if (msymbol.minsym != NULL)
705			    write_exp_msymbol (pstate, msymbol);
706			  else if (!have_full_symbols ()
707				   && !have_partial_symbols ())
708			    error (_("No symbol table is loaded.  "
709				   "Use the \"file\" command."));
710			  else
711			    error (_("No symbol \"%s\" in current context."),
712				   name.c_str ());
713			}
714	;
715
716variable:	name_not_typename
717			{ struct block_symbol sym = $1.sym;
718
719			  if (sym.symbol)
720			    {
721			      if (symbol_read_needs_frame (sym.symbol))
722				pstate->block_tracker->update (sym);
723
724			      write_exp_elt_opcode (pstate, OP_VAR_VALUE);
725			      write_exp_elt_block (pstate, sym.block);
726			      write_exp_elt_sym (pstate, sym.symbol);
727			      write_exp_elt_opcode (pstate, OP_VAR_VALUE);
728			      current_type = sym.symbol->type; }
729			  else if ($1.is_a_field_of_this)
730			    {
731			      struct value * this_val;
732			      struct type * this_type;
733			      /* Object pascal: it hangs off of `this'.  Must
734			         not inadvertently convert from a method call
735				 to data ref.  */
736			      pstate->block_tracker->update (sym);
737			      write_exp_elt_opcode (pstate, OP_THIS);
738			      write_exp_elt_opcode (pstate, OP_THIS);
739			      write_exp_elt_opcode (pstate, STRUCTOP_PTR);
740			      write_exp_string (pstate, $1.stoken);
741			      write_exp_elt_opcode (pstate, STRUCTOP_PTR);
742			      /* We need type of this.  */
743			      this_val
744				= value_of_this_silent (pstate->language ());
745			      if (this_val)
746				this_type = value_type (this_val);
747			      else
748				this_type = NULL;
749			      if (this_type)
750				current_type = lookup_struct_elt_type (
751				  this_type,
752				  copy_name ($1.stoken).c_str (), 0);
753			      else
754				current_type = NULL;
755			    }
756			  else
757			    {
758			      struct bound_minimal_symbol msymbol;
759			      std::string arg = copy_name ($1.stoken);
760
761			      msymbol =
762				lookup_bound_minimal_symbol (arg.c_str ());
763			      if (msymbol.minsym != NULL)
764				write_exp_msymbol (pstate, msymbol);
765			      else if (!have_full_symbols ()
766				       && !have_partial_symbols ())
767				error (_("No symbol table is loaded.  "
768				       "Use the \"file\" command."));
769			      else
770				error (_("No symbol \"%s\" in current context."),
771				       arg.c_str ());
772			    }
773			}
774	;
775
776
777ptype	:	typebase
778	;
779
780/* We used to try to recognize more pointer to member types here, but
781   that didn't work (shift/reduce conflicts meant that these rules never
782   got executed).  The problem is that
783     int (foo::bar::baz::bizzle)
784   is a function type but
785     int (foo::bar::baz::bizzle::*)
786   is a pointer to member type.  Stroustrup loses again!  */
787
788type	:	ptype
789	;
790
791typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
792	:	'^' typebase
793			{ $$ = lookup_pointer_type ($2); }
794	|	TYPENAME
795			{ $$ = $1.type; }
796	|	STRUCT name
797			{ $$
798			    = lookup_struct (copy_name ($2).c_str (),
799					     pstate->expression_context_block);
800			}
801	|	CLASS name
802			{ $$
803			    = lookup_struct (copy_name ($2).c_str (),
804					     pstate->expression_context_block);
805			}
806	/* "const" and "volatile" are curently ignored.  A type qualifier
807	   after the type is handled in the ptype rule.  I think these could
808	   be too.  */
809	;
810
811name	:	NAME { $$ = $1.stoken; }
812	|	BLOCKNAME { $$ = $1.stoken; }
813	|	TYPENAME { $$ = $1.stoken; }
814	|	NAME_OR_INT  { $$ = $1.stoken; }
815	;
816
817name_not_typename :	NAME
818	|	BLOCKNAME
819/* These would be useful if name_not_typename was useful, but it is just
820   a fake for "variable", so these cause reduce/reduce conflicts because
821   the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
822   =exp) or just an exp.  If name_not_typename was ever used in an lvalue
823   context where only a name could occur, this might be useful.
824  	|	NAME_OR_INT
825 */
826	;
827
828%%
829
830/* Take care of parsing a number (anything that starts with a digit).
831   Set yylval and return the token type; update lexptr.
832   LEN is the number of characters in it.  */
833
834/*** Needs some error checking for the float case ***/
835
836static int
837parse_number (struct parser_state *par_state,
838	      const char *p, int len, int parsed_float, YYSTYPE *putithere)
839{
840  /* FIXME: Shouldn't these be unsigned?  We don't deal with negative values
841     here, and we do kind of silly things like cast to unsigned.  */
842  LONGEST n = 0;
843  LONGEST prevn = 0;
844  ULONGEST un;
845
846  int i = 0;
847  int c;
848  int base = input_radix;
849  int unsigned_p = 0;
850
851  /* Number of "L" suffixes encountered.  */
852  int long_p = 0;
853
854  /* We have found a "L" or "U" suffix.  */
855  int found_suffix = 0;
856
857  ULONGEST high_bit;
858  struct type *signed_type;
859  struct type *unsigned_type;
860
861  if (parsed_float)
862    {
863      /* Handle suffixes: 'f' for float, 'l' for long double.
864         FIXME: This appears to be an extension -- do we want this?  */
865      if (len >= 1 && tolower (p[len - 1]) == 'f')
866	{
867	  putithere->typed_val_float.type
868	    = parse_type (par_state)->builtin_float;
869	  len--;
870	}
871      else if (len >= 1 && tolower (p[len - 1]) == 'l')
872	{
873	  putithere->typed_val_float.type
874	    = parse_type (par_state)->builtin_long_double;
875	  len--;
876	}
877      /* Default type for floating-point literals is double.  */
878      else
879	{
880	  putithere->typed_val_float.type
881	    = parse_type (par_state)->builtin_double;
882	}
883
884      if (!parse_float (p, len,
885			putithere->typed_val_float.type,
886			putithere->typed_val_float.val))
887	return ERROR;
888      return FLOAT;
889    }
890
891  /* Handle base-switching prefixes 0x, 0t, 0d, 0.  */
892  if (p[0] == '0')
893    switch (p[1])
894      {
895      case 'x':
896      case 'X':
897	if (len >= 3)
898	  {
899	    p += 2;
900	    base = 16;
901	    len -= 2;
902	  }
903	break;
904
905      case 't':
906      case 'T':
907      case 'd':
908      case 'D':
909	if (len >= 3)
910	  {
911	    p += 2;
912	    base = 10;
913	    len -= 2;
914	  }
915	break;
916
917      default:
918	base = 8;
919	break;
920      }
921
922  while (len-- > 0)
923    {
924      c = *p++;
925      if (c >= 'A' && c <= 'Z')
926	c += 'a' - 'A';
927      if (c != 'l' && c != 'u')
928	n *= base;
929      if (c >= '0' && c <= '9')
930	{
931	  if (found_suffix)
932	    return ERROR;
933	  n += i = c - '0';
934	}
935      else
936	{
937	  if (base > 10 && c >= 'a' && c <= 'f')
938	    {
939	      if (found_suffix)
940		return ERROR;
941	      n += i = c - 'a' + 10;
942	    }
943	  else if (c == 'l')
944	    {
945	      ++long_p;
946	      found_suffix = 1;
947	    }
948	  else if (c == 'u')
949	    {
950	      unsigned_p = 1;
951	      found_suffix = 1;
952	    }
953	  else
954	    return ERROR;	/* Char not a digit */
955	}
956      if (i >= base)
957	return ERROR;		/* Invalid digit in this base.  */
958
959      /* Portably test for overflow (only works for nonzero values, so make
960	 a second check for zero).  FIXME: Can't we just make n and prevn
961	 unsigned and avoid this?  */
962      if (c != 'l' && c != 'u' && (prevn >= n) && n != 0)
963	unsigned_p = 1;		/* Try something unsigned.  */
964
965      /* Portably test for unsigned overflow.
966	 FIXME: This check is wrong; for example it doesn't find overflow
967	 on 0x123456789 when LONGEST is 32 bits.  */
968      if (c != 'l' && c != 'u' && n != 0)
969	{
970	  if ((unsigned_p && (ULONGEST) prevn >= (ULONGEST) n))
971	    error (_("Numeric constant too large."));
972	}
973      prevn = n;
974    }
975
976  /* An integer constant is an int, a long, or a long long.  An L
977     suffix forces it to be long; an LL suffix forces it to be long
978     long.  If not forced to a larger size, it gets the first type of
979     the above that it fits in.  To figure out whether it fits, we
980     shift it right and see whether anything remains.  Note that we
981     can't shift sizeof (LONGEST) * HOST_CHAR_BIT bits or more in one
982     operation, because many compilers will warn about such a shift
983     (which always produces a zero result).  Sometimes gdbarch_int_bit
984     or gdbarch_long_bit will be that big, sometimes not.  To deal with
985     the case where it is we just always shift the value more than
986     once, with fewer bits each time.  */
987
988  un = (ULONGEST)n >> 2;
989  if (long_p == 0
990      && (un >> (gdbarch_int_bit (par_state->gdbarch ()) - 2)) == 0)
991    {
992      high_bit
993	= ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
994
995      /* A large decimal (not hex or octal) constant (between INT_MAX
996	 and UINT_MAX) is a long or unsigned long, according to ANSI,
997	 never an unsigned int, but this code treats it as unsigned
998	 int.  This probably should be fixed.  GCC gives a warning on
999	 such constants.  */
1000
1001      unsigned_type = parse_type (par_state)->builtin_unsigned_int;
1002      signed_type = parse_type (par_state)->builtin_int;
1003    }
1004  else if (long_p <= 1
1005	   && (un >> (gdbarch_long_bit (par_state->gdbarch ()) - 2)) == 0)
1006    {
1007      high_bit
1008	= ((ULONGEST)1) << (gdbarch_long_bit (par_state->gdbarch ()) - 1);
1009      unsigned_type = parse_type (par_state)->builtin_unsigned_long;
1010      signed_type = parse_type (par_state)->builtin_long;
1011    }
1012  else
1013    {
1014      int shift;
1015      if (sizeof (ULONGEST) * HOST_CHAR_BIT
1016	  < gdbarch_long_long_bit (par_state->gdbarch ()))
1017	/* A long long does not fit in a LONGEST.  */
1018	shift = (sizeof (ULONGEST) * HOST_CHAR_BIT - 1);
1019      else
1020	shift = (gdbarch_long_long_bit (par_state->gdbarch ()) - 1);
1021      high_bit = (ULONGEST) 1 << shift;
1022      unsigned_type = parse_type (par_state)->builtin_unsigned_long_long;
1023      signed_type = parse_type (par_state)->builtin_long_long;
1024    }
1025
1026   putithere->typed_val_int.val = n;
1027
1028   /* If the high bit of the worked out type is set then this number
1029      has to be unsigned.  */
1030
1031   if (unsigned_p || (n & high_bit))
1032     {
1033       putithere->typed_val_int.type = unsigned_type;
1034     }
1035   else
1036     {
1037       putithere->typed_val_int.type = signed_type;
1038     }
1039
1040   return INT;
1041}
1042
1043
1044struct type_push
1045{
1046  struct type *stored;
1047  struct type_push *next;
1048};
1049
1050static struct type_push *tp_top = NULL;
1051
1052static void
1053push_current_type (void)
1054{
1055  struct type_push *tpnew;
1056  tpnew = (struct type_push *) malloc (sizeof (struct type_push));
1057  tpnew->next = tp_top;
1058  tpnew->stored = current_type;
1059  current_type = NULL;
1060  tp_top = tpnew;
1061}
1062
1063static void
1064pop_current_type (void)
1065{
1066  struct type_push *tp = tp_top;
1067  if (tp)
1068    {
1069      current_type = tp->stored;
1070      tp_top = tp->next;
1071      free (tp);
1072    }
1073}
1074
1075struct token
1076{
1077  const char *oper;
1078  int token;
1079  enum exp_opcode opcode;
1080};
1081
1082static const struct token tokentab3[] =
1083  {
1084    {"shr", RSH, BINOP_END},
1085    {"shl", LSH, BINOP_END},
1086    {"and", ANDAND, BINOP_END},
1087    {"div", DIV, BINOP_END},
1088    {"not", NOT, BINOP_END},
1089    {"mod", MOD, BINOP_END},
1090    {"inc", INCREMENT, BINOP_END},
1091    {"dec", DECREMENT, BINOP_END},
1092    {"xor", XOR, BINOP_END}
1093  };
1094
1095static const struct token tokentab2[] =
1096  {
1097    {"or", OR, BINOP_END},
1098    {"<>", NOTEQUAL, BINOP_END},
1099    {"<=", LEQ, BINOP_END},
1100    {">=", GEQ, BINOP_END},
1101    {":=", ASSIGN, BINOP_END},
1102    {"::", COLONCOLON, BINOP_END} };
1103
1104/* Allocate uppercased var: */
1105/* make an uppercased copy of tokstart.  */
1106static char *
1107uptok (const char *tokstart, int namelen)
1108{
1109  int i;
1110  char *uptokstart = (char *)malloc(namelen+1);
1111  for (i = 0;i <= namelen;i++)
1112    {
1113      if ((tokstart[i]>='a' && tokstart[i]<='z'))
1114        uptokstart[i] = tokstart[i]-('a'-'A');
1115      else
1116        uptokstart[i] = tokstart[i];
1117    }
1118  uptokstart[namelen]='\0';
1119  return uptokstart;
1120}
1121
1122/* Read one token, getting characters through lexptr.  */
1123
1124static int
1125yylex (void)
1126{
1127  int c;
1128  int namelen;
1129  const char *tokstart;
1130  char *uptokstart;
1131  const char *tokptr;
1132  int explen, tempbufindex;
1133  static char *tempbuf;
1134  static int tempbufsize;
1135
1136 retry:
1137
1138  pstate->prev_lexptr = pstate->lexptr;
1139
1140  tokstart = pstate->lexptr;
1141  explen = strlen (pstate->lexptr);
1142
1143  /* See if it is a special token of length 3.  */
1144  if (explen > 2)
1145    for (int i = 0; i < sizeof (tokentab3) / sizeof (tokentab3[0]); i++)
1146      if (strncasecmp (tokstart, tokentab3[i].oper, 3) == 0
1147          && (!isalpha (tokentab3[i].oper[0]) || explen == 3
1148              || (!isalpha (tokstart[3])
1149		  && !isdigit (tokstart[3]) && tokstart[3] != '_')))
1150        {
1151          pstate->lexptr += 3;
1152          yylval.opcode = tokentab3[i].opcode;
1153          return tokentab3[i].token;
1154        }
1155
1156  /* See if it is a special token of length 2.  */
1157  if (explen > 1)
1158  for (int i = 0; i < sizeof (tokentab2) / sizeof (tokentab2[0]); i++)
1159      if (strncasecmp (tokstart, tokentab2[i].oper, 2) == 0
1160          && (!isalpha (tokentab2[i].oper[0]) || explen == 2
1161              || (!isalpha (tokstart[2])
1162		  && !isdigit (tokstart[2]) && tokstart[2] != '_')))
1163        {
1164          pstate->lexptr += 2;
1165          yylval.opcode = tokentab2[i].opcode;
1166          return tokentab2[i].token;
1167        }
1168
1169  switch (c = *tokstart)
1170    {
1171    case 0:
1172      if (search_field && pstate->parse_completion)
1173	return COMPLETE;
1174      else
1175       return 0;
1176
1177    case ' ':
1178    case '\t':
1179    case '\n':
1180      pstate->lexptr++;
1181      goto retry;
1182
1183    case '\'':
1184      /* We either have a character constant ('0' or '\177' for example)
1185	 or we have a quoted symbol reference ('foo(int,int)' in object pascal
1186	 for example).  */
1187      pstate->lexptr++;
1188      c = *pstate->lexptr++;
1189      if (c == '\\')
1190	c = parse_escape (pstate->gdbarch (), &pstate->lexptr);
1191      else if (c == '\'')
1192	error (_("Empty character constant."));
1193
1194      yylval.typed_val_int.val = c;
1195      yylval.typed_val_int.type = parse_type (pstate)->builtin_char;
1196
1197      c = *pstate->lexptr++;
1198      if (c != '\'')
1199	{
1200	  namelen = skip_quoted (tokstart) - tokstart;
1201	  if (namelen > 2)
1202	    {
1203	      pstate->lexptr = tokstart + namelen;
1204	      if (pstate->lexptr[-1] != '\'')
1205		error (_("Unmatched single quote."));
1206	      namelen -= 2;
1207              tokstart++;
1208              uptokstart = uptok(tokstart,namelen);
1209	      goto tryname;
1210	    }
1211	  error (_("Invalid character constant."));
1212	}
1213      return INT;
1214
1215    case '(':
1216      paren_depth++;
1217      pstate->lexptr++;
1218      return c;
1219
1220    case ')':
1221      if (paren_depth == 0)
1222	return 0;
1223      paren_depth--;
1224      pstate->lexptr++;
1225      return c;
1226
1227    case ',':
1228      if (pstate->comma_terminates && paren_depth == 0)
1229	return 0;
1230      pstate->lexptr++;
1231      return c;
1232
1233    case '.':
1234      /* Might be a floating point number.  */
1235      if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1236	{
1237	  goto symbol;		/* Nope, must be a symbol.  */
1238	}
1239
1240      /* FALL THRU.  */
1241
1242    case '0':
1243    case '1':
1244    case '2':
1245    case '3':
1246    case '4':
1247    case '5':
1248    case '6':
1249    case '7':
1250    case '8':
1251    case '9':
1252      {
1253	/* It's a number.  */
1254	int got_dot = 0, got_e = 0, toktype;
1255	const char *p = tokstart;
1256	int hex = input_radix > 10;
1257
1258	if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1259	  {
1260	    p += 2;
1261	    hex = 1;
1262	  }
1263	else if (c == '0' && (p[1]=='t' || p[1]=='T'
1264			      || p[1]=='d' || p[1]=='D'))
1265	  {
1266	    p += 2;
1267	    hex = 0;
1268	  }
1269
1270	for (;; ++p)
1271	  {
1272	    /* This test includes !hex because 'e' is a valid hex digit
1273	       and thus does not indicate a floating point number when
1274	       the radix is hex.  */
1275	    if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1276	      got_dot = got_e = 1;
1277	    /* This test does not include !hex, because a '.' always indicates
1278	       a decimal floating point number regardless of the radix.  */
1279	    else if (!got_dot && *p == '.')
1280	      got_dot = 1;
1281	    else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
1282		     && (*p == '-' || *p == '+'))
1283	      /* This is the sign of the exponent, not the end of the
1284		 number.  */
1285	      continue;
1286	    /* We will take any letters or digits.  parse_number will
1287	       complain if past the radix, or if L or U are not final.  */
1288	    else if ((*p < '0' || *p > '9')
1289		     && ((*p < 'a' || *p > 'z')
1290				  && (*p < 'A' || *p > 'Z')))
1291	      break;
1292	  }
1293	toktype = parse_number (pstate, tokstart,
1294				p - tokstart, got_dot | got_e, &yylval);
1295        if (toktype == ERROR)
1296	  {
1297	    char *err_copy = (char *) alloca (p - tokstart + 1);
1298
1299	    memcpy (err_copy, tokstart, p - tokstart);
1300	    err_copy[p - tokstart] = 0;
1301	    error (_("Invalid number \"%s\"."), err_copy);
1302	  }
1303	pstate->lexptr = p;
1304	return toktype;
1305      }
1306
1307    case '+':
1308    case '-':
1309    case '*':
1310    case '/':
1311    case '|':
1312    case '&':
1313    case '^':
1314    case '~':
1315    case '!':
1316    case '@':
1317    case '<':
1318    case '>':
1319    case '[':
1320    case ']':
1321    case '?':
1322    case ':':
1323    case '=':
1324    case '{':
1325    case '}':
1326    symbol:
1327      pstate->lexptr++;
1328      return c;
1329
1330    case '"':
1331
1332      /* Build the gdb internal form of the input string in tempbuf,
1333	 translating any standard C escape forms seen.  Note that the
1334	 buffer is null byte terminated *only* for the convenience of
1335	 debugging gdb itself and printing the buffer contents when
1336	 the buffer contains no embedded nulls.  Gdb does not depend
1337	 upon the buffer being null byte terminated, it uses the length
1338	 string instead.  This allows gdb to handle C strings (as well
1339	 as strings in other languages) with embedded null bytes.  */
1340
1341      tokptr = ++tokstart;
1342      tempbufindex = 0;
1343
1344      do {
1345	/* Grow the static temp buffer if necessary, including allocating
1346	   the first one on demand.  */
1347	if (tempbufindex + 1 >= tempbufsize)
1348	  {
1349	    tempbuf = (char *) realloc (tempbuf, tempbufsize += 64);
1350	  }
1351
1352	switch (*tokptr)
1353	  {
1354	  case '\0':
1355	  case '"':
1356	    /* Do nothing, loop will terminate.  */
1357	    break;
1358	  case '\\':
1359	    ++tokptr;
1360	    c = parse_escape (pstate->gdbarch (), &tokptr);
1361	    if (c == -1)
1362	      {
1363		continue;
1364	      }
1365	    tempbuf[tempbufindex++] = c;
1366	    break;
1367	  default:
1368	    tempbuf[tempbufindex++] = *tokptr++;
1369	    break;
1370	  }
1371      } while ((*tokptr != '"') && (*tokptr != '\0'));
1372      if (*tokptr++ != '"')
1373	{
1374	  error (_("Unterminated string in expression."));
1375	}
1376      tempbuf[tempbufindex] = '\0';	/* See note above.  */
1377      yylval.sval.ptr = tempbuf;
1378      yylval.sval.length = tempbufindex;
1379      pstate->lexptr = tokptr;
1380      return (STRING);
1381    }
1382
1383  if (!(c == '_' || c == '$'
1384	|| (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1385    /* We must have come across a bad character (e.g. ';').  */
1386    error (_("Invalid character '%c' in expression."), c);
1387
1388  /* It's a name.  See how long it is.  */
1389  namelen = 0;
1390  for (c = tokstart[namelen];
1391       (c == '_' || c == '$' || (c >= '0' && c <= '9')
1392	|| (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c == '<');)
1393    {
1394      /* Template parameter lists are part of the name.
1395	 FIXME: This mishandles `print $a<4&&$a>3'.  */
1396      if (c == '<')
1397	{
1398	  int i = namelen;
1399	  int nesting_level = 1;
1400	  while (tokstart[++i])
1401	    {
1402	      if (tokstart[i] == '<')
1403		nesting_level++;
1404	      else if (tokstart[i] == '>')
1405		{
1406		  if (--nesting_level == 0)
1407		    break;
1408		}
1409	    }
1410	  if (tokstart[i] == '>')
1411	    namelen = i;
1412	  else
1413	    break;
1414	}
1415
1416      /* do NOT uppercase internals because of registers !!!  */
1417      c = tokstart[++namelen];
1418    }
1419
1420  uptokstart = uptok(tokstart,namelen);
1421
1422  /* The token "if" terminates the expression and is NOT
1423     removed from the input stream.  */
1424  if (namelen == 2 && uptokstart[0] == 'I' && uptokstart[1] == 'F')
1425    {
1426      free (uptokstart);
1427      return 0;
1428    }
1429
1430  pstate->lexptr += namelen;
1431
1432  tryname:
1433
1434  /* Catch specific keywords.  Should be done with a data structure.  */
1435  switch (namelen)
1436    {
1437    case 6:
1438      if (strcmp (uptokstart, "OBJECT") == 0)
1439	{
1440	  free (uptokstart);
1441	  return CLASS;
1442	}
1443      if (strcmp (uptokstart, "RECORD") == 0)
1444	{
1445	  free (uptokstart);
1446	  return STRUCT;
1447	}
1448      if (strcmp (uptokstart, "SIZEOF") == 0)
1449	{
1450	  free (uptokstart);
1451	  return SIZEOF;
1452	}
1453      break;
1454    case 5:
1455      if (strcmp (uptokstart, "CLASS") == 0)
1456	{
1457	  free (uptokstart);
1458	  return CLASS;
1459	}
1460      if (strcmp (uptokstart, "FALSE") == 0)
1461	{
1462          yylval.lval = 0;
1463	  free (uptokstart);
1464          return FALSEKEYWORD;
1465        }
1466      break;
1467    case 4:
1468      if (strcmp (uptokstart, "TRUE") == 0)
1469	{
1470          yylval.lval = 1;
1471	  free (uptokstart);
1472  	  return TRUEKEYWORD;
1473        }
1474      if (strcmp (uptokstart, "SELF") == 0)
1475        {
1476          /* Here we search for 'this' like
1477             inserted in FPC stabs debug info.  */
1478	  static const char this_name[] = "this";
1479
1480	  if (lookup_symbol (this_name, pstate->expression_context_block,
1481			     VAR_DOMAIN, NULL).symbol)
1482	    {
1483	      free (uptokstart);
1484	      return THIS;
1485	    }
1486	}
1487      break;
1488    default:
1489      break;
1490    }
1491
1492  yylval.sval.ptr = tokstart;
1493  yylval.sval.length = namelen;
1494
1495  if (*tokstart == '$')
1496    {
1497      char *tmp;
1498
1499      /* $ is the normal prefix for pascal hexadecimal values
1500        but this conflicts with the GDB use for debugger variables
1501        so in expression to enter hexadecimal values
1502        we still need to use C syntax with 0xff  */
1503      write_dollar_variable (pstate, yylval.sval);
1504      tmp = (char *) alloca (namelen + 1);
1505      memcpy (tmp, tokstart, namelen);
1506      tmp[namelen] = '\0';
1507      intvar = lookup_only_internalvar (tmp + 1);
1508      free (uptokstart);
1509      return DOLLAR_VARIABLE;
1510    }
1511
1512  /* Use token-type BLOCKNAME for symbols that happen to be defined as
1513     functions or symtabs.  If this is not so, then ...
1514     Use token-type TYPENAME for symbols that happen to be defined
1515     currently as names of types; NAME for other symbols.
1516     The caller is not constrained to care about the distinction.  */
1517  {
1518    std::string tmp = copy_name (yylval.sval);
1519    struct symbol *sym;
1520    struct field_of_this_result is_a_field_of_this = { .type = NULL };
1521    int is_a_field = 0;
1522    int hextype;
1523
1524    is_a_field_of_this.type = NULL;
1525    if (search_field && current_type)
1526      is_a_field = (lookup_struct_elt_type (current_type,
1527					    tmp.c_str (), 1) != NULL);
1528    if (is_a_field)
1529      sym = NULL;
1530    else
1531      sym = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1532			   VAR_DOMAIN, &is_a_field_of_this).symbol;
1533    /* second chance uppercased (as Free Pascal does).  */
1534    if (!sym && is_a_field_of_this.type == NULL && !is_a_field)
1535      {
1536       for (int i = 0; i <= namelen; i++)
1537         {
1538           if ((tmp[i] >= 'a' && tmp[i] <= 'z'))
1539             tmp[i] -= ('a'-'A');
1540         }
1541       if (search_field && current_type)
1542	 is_a_field = (lookup_struct_elt_type (current_type,
1543					       tmp.c_str (), 1) != NULL);
1544       if (is_a_field)
1545	 sym = NULL;
1546       else
1547	 sym = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1548			      VAR_DOMAIN, &is_a_field_of_this).symbol;
1549      }
1550    /* Third chance Capitalized (as GPC does).  */
1551    if (!sym && is_a_field_of_this.type == NULL && !is_a_field)
1552      {
1553       for (int i = 0; i <= namelen; i++)
1554         {
1555           if (i == 0)
1556             {
1557              if ((tmp[i] >= 'a' && tmp[i] <= 'z'))
1558                tmp[i] -= ('a'-'A');
1559             }
1560           else
1561           if ((tmp[i] >= 'A' && tmp[i] <= 'Z'))
1562             tmp[i] -= ('A'-'a');
1563          }
1564       if (search_field && current_type)
1565	 is_a_field = (lookup_struct_elt_type (current_type,
1566					       tmp.c_str (), 1) != NULL);
1567       if (is_a_field)
1568	 sym = NULL;
1569       else
1570	 sym = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1571			      VAR_DOMAIN, &is_a_field_of_this).symbol;
1572      }
1573
1574    if (is_a_field || (is_a_field_of_this.type != NULL))
1575      {
1576	tempbuf = (char *) realloc (tempbuf, namelen + 1);
1577	strncpy (tempbuf, tmp.c_str (), namelen);
1578	tempbuf [namelen] = 0;
1579	yylval.sval.ptr = tempbuf;
1580	yylval.sval.length = namelen;
1581	yylval.ssym.sym.symbol = NULL;
1582	yylval.ssym.sym.block = NULL;
1583	free (uptokstart);
1584        yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1585	if (is_a_field)
1586	  return FIELDNAME;
1587	else
1588	  return NAME;
1589      }
1590    /* Call lookup_symtab, not lookup_partial_symtab, in case there are
1591       no psymtabs (coff, xcoff, or some future change to blow away the
1592       psymtabs once once symbols are read).  */
1593    if ((sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
1594        || lookup_symtab (tmp.c_str ()))
1595      {
1596	yylval.ssym.sym.symbol = sym;
1597	yylval.ssym.sym.block = NULL;
1598	yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1599	free (uptokstart);
1600	return BLOCKNAME;
1601      }
1602    if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
1603        {
1604#if 1
1605	  /* Despite the following flaw, we need to keep this code enabled.
1606	     Because we can get called from check_stub_method, if we don't
1607	     handle nested types then it screws many operations in any
1608	     program which uses nested types.  */
1609	  /* In "A::x", if x is a member function of A and there happens
1610	     to be a type (nested or not, since the stabs don't make that
1611	     distinction) named x, then this code incorrectly thinks we
1612	     are dealing with nested types rather than a member function.  */
1613
1614	  const char *p;
1615	  const char *namestart;
1616	  struct symbol *best_sym;
1617
1618	  /* Look ahead to detect nested types.  This probably should be
1619	     done in the grammar, but trying seemed to introduce a lot
1620	     of shift/reduce and reduce/reduce conflicts.  It's possible
1621	     that it could be done, though.  Or perhaps a non-grammar, but
1622	     less ad hoc, approach would work well.  */
1623
1624	  /* Since we do not currently have any way of distinguishing
1625	     a nested type from a non-nested one (the stabs don't tell
1626	     us whether a type is nested), we just ignore the
1627	     containing type.  */
1628
1629	  p = pstate->lexptr;
1630	  best_sym = sym;
1631	  while (1)
1632	    {
1633	      /* Skip whitespace.  */
1634	      while (*p == ' ' || *p == '\t' || *p == '\n')
1635		++p;
1636	      if (*p == ':' && p[1] == ':')
1637		{
1638		  /* Skip the `::'.  */
1639		  p += 2;
1640		  /* Skip whitespace.  */
1641		  while (*p == ' ' || *p == '\t' || *p == '\n')
1642		    ++p;
1643		  namestart = p;
1644		  while (*p == '_' || *p == '$' || (*p >= '0' && *p <= '9')
1645			 || (*p >= 'a' && *p <= 'z')
1646			 || (*p >= 'A' && *p <= 'Z'))
1647		    ++p;
1648		  if (p != namestart)
1649		    {
1650		      struct symbol *cur_sym;
1651		      /* As big as the whole rest of the expression, which is
1652			 at least big enough.  */
1653		      char *ncopy
1654			= (char *) alloca (tmp.size () + strlen (namestart)
1655					   + 3);
1656		      char *tmp1;
1657
1658		      tmp1 = ncopy;
1659		      memcpy (tmp1, tmp.c_str (), tmp.size ());
1660		      tmp1 += tmp.size ();
1661		      memcpy (tmp1, "::", 2);
1662		      tmp1 += 2;
1663		      memcpy (tmp1, namestart, p - namestart);
1664		      tmp1[p - namestart] = '\0';
1665		      cur_sym
1666			= lookup_symbol (ncopy,
1667					 pstate->expression_context_block,
1668					 VAR_DOMAIN, NULL).symbol;
1669		      if (cur_sym)
1670			{
1671			  if (SYMBOL_CLASS (cur_sym) == LOC_TYPEDEF)
1672			    {
1673			      best_sym = cur_sym;
1674			      pstate->lexptr = p;
1675			    }
1676			  else
1677			    break;
1678			}
1679		      else
1680			break;
1681		    }
1682		  else
1683		    break;
1684		}
1685	      else
1686		break;
1687	    }
1688
1689	  yylval.tsym.type = SYMBOL_TYPE (best_sym);
1690#else /* not 0 */
1691	  yylval.tsym.type = SYMBOL_TYPE (sym);
1692#endif /* not 0 */
1693	  free (uptokstart);
1694	  return TYPENAME;
1695        }
1696    yylval.tsym.type
1697      = language_lookup_primitive_type (pstate->language (),
1698					pstate->gdbarch (), tmp.c_str ());
1699    if (yylval.tsym.type != NULL)
1700      {
1701	free (uptokstart);
1702	return TYPENAME;
1703      }
1704
1705    /* Input names that aren't symbols but ARE valid hex numbers,
1706       when the input radix permits them, can be names or numbers
1707       depending on the parse.  Note we support radixes > 16 here.  */
1708    if (!sym
1709        && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1710            || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1711      {
1712 	YYSTYPE newlval;	/* Its value is ignored.  */
1713	hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1714	if (hextype == INT)
1715	  {
1716	    yylval.ssym.sym.symbol = sym;
1717	    yylval.ssym.sym.block = NULL;
1718	    yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1719	    free (uptokstart);
1720	    return NAME_OR_INT;
1721	  }
1722      }
1723
1724    free(uptokstart);
1725    /* Any other kind of symbol.  */
1726    yylval.ssym.sym.symbol = sym;
1727    yylval.ssym.sym.block = NULL;
1728    return NAME;
1729  }
1730}
1731
1732int
1733pascal_parse (struct parser_state *par_state)
1734{
1735  /* Setting up the parser state.  */
1736  scoped_restore pstate_restore = make_scoped_restore (&pstate);
1737  gdb_assert (par_state != NULL);
1738  pstate = par_state;
1739  paren_depth = 0;
1740
1741  return yyparse ();
1742}
1743
1744static void
1745yyerror (const char *msg)
1746{
1747  if (pstate->prev_lexptr)
1748    pstate->lexptr = pstate->prev_lexptr;
1749
1750  error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);
1751}
1752