xref: /netbsd-src/external/gpl3/gdb.old/dist/gdb/m2-exp.y (revision cb63e24e8d6aae7ddac1859a9015f48b1d8bd90e)
1 /* YACC grammar for Modula-2 expressions, for GDB.
2    Copyright (C) 1986-2020 Free Software Foundation, Inc.
3    Generated from expread.y (now c-exp.y) and contributed by the Department
4    of Computer Science at the State University of New York at Buffalo, 1991.
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 /* Parse a Modula-2 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 %{
39 
40 #include "defs.h"
41 #include "expression.h"
42 #include "language.h"
43 #include "value.h"
44 #include "parser-defs.h"
45 #include "m2-lang.h"
46 #include "bfd.h" /* Required by objfiles.h.  */
47 #include "symfile.h" /* Required by objfiles.h.  */
48 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
49 #include "block.h"
50 
51 #define parse_type(ps) builtin_type (ps->gdbarch ())
52 #define parse_m2_type(ps) builtin_m2_type (ps->gdbarch ())
53 
54 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
55    etc).  */
56 #define GDB_YY_REMAP_PREFIX m2_
57 #include "yy-remap.h"
58 
59 /* The state of the parser, used internally when we are parsing the
60    expression.  */
61 
62 static struct parser_state *pstate = NULL;
63 
64 int yyparse (void);
65 
66 static int yylex (void);
67 
68 static void yyerror (const char *);
69 
70 static int parse_number (int);
71 
72 /* The sign of the number being parsed.  */
73 static int number_sign = 1;
74 
75 %}
76 
77 /* Although the yacc "value" of an expression is not used,
78    since the result is stored in the structure being created,
79    other node types do have values.  */
80 
81 %union
82   {
83     LONGEST lval;
84     ULONGEST ulval;
85     gdb_byte val[16];
86     struct symbol *sym;
87     struct type *tval;
88     struct stoken sval;
89     int voidval;
90     const struct block *bval;
91     enum exp_opcode opcode;
92     struct internalvar *ivar;
93 
94     struct type **tvec;
95     int *ivec;
96   }
97 
98 %type <voidval> exp type_exp start set
99 %type <voidval> variable
100 %type <tval> type
101 %type <bval> block
102 %type <sym> fblock
103 
104 %token <lval> INT HEX ERROR
105 %token <ulval> UINT M2_TRUE M2_FALSE CHAR
106 %token <val> FLOAT
107 
108 /* Both NAME and TYPENAME tokens represent symbols in the input,
109    and both convey their data as strings.
110    But a TYPENAME is a string that happens to be defined as a typedef
111    or builtin type name (such as int or char)
112    and a NAME is any other symbol.
113 
114    Contexts where this distinction is not important can use the
115    nonterminal "name", which matches either NAME or TYPENAME.  */
116 
117 %token <sval> STRING
118 %token <sval> NAME BLOCKNAME IDENT VARNAME
119 %token <sval> TYPENAME
120 
121 %token SIZE CAP ORD HIGH ABS MIN_FUNC MAX_FUNC FLOAT_FUNC VAL CHR ODD TRUNC
122 %token TSIZE
123 %token INC DEC INCL EXCL
124 
125 /* The GDB scope operator */
126 %token COLONCOLON
127 
128 %token <voidval> DOLLAR_VARIABLE
129 
130 /* M2 tokens */
131 %left ','
132 %left ABOVE_COMMA
133 %nonassoc ASSIGN
134 %left '<' '>' LEQ GEQ '=' NOTEQUAL '#' IN
135 %left OROR
136 %left LOGICAL_AND '&'
137 %left '@'
138 %left '+' '-'
139 %left '*' '/' DIV MOD
140 %right UNARY
141 %right '^' DOT '[' '('
142 %right NOT '~'
143 %left COLONCOLON QID
144 /* This is not an actual token ; it is used for precedence.
145 %right QID
146 */
147 
148 
149 %%
150 
151 start   :	exp
152 	|	type_exp
153 	;
154 
155 type_exp:	type
156 		{ write_exp_elt_opcode (pstate, OP_TYPE);
157 		  write_exp_elt_type (pstate, $1);
158 		  write_exp_elt_opcode (pstate, OP_TYPE);
159 		}
160 	;
161 
162 /* Expressions */
163 
164 exp     :       exp '^'   %prec UNARY
165                         { write_exp_elt_opcode (pstate, UNOP_IND); }
166 	;
167 
168 exp	:	'-'
169 			{ number_sign = -1; }
170 		exp    %prec UNARY
171 			{ number_sign = 1;
172 			  write_exp_elt_opcode (pstate, UNOP_NEG); }
173 	;
174 
175 exp	:	'+' exp    %prec UNARY
176 		{ write_exp_elt_opcode (pstate, UNOP_PLUS); }
177 	;
178 
179 exp	:	not_exp exp %prec UNARY
180 			{ write_exp_elt_opcode (pstate, UNOP_LOGICAL_NOT); }
181 	;
182 
183 not_exp	:	NOT
184 	|	'~'
185 	;
186 
187 exp	:	CAP '(' exp ')'
188 			{ write_exp_elt_opcode (pstate, UNOP_CAP); }
189 	;
190 
191 exp	:	ORD '(' exp ')'
192 			{ write_exp_elt_opcode (pstate, UNOP_ORD); }
193 	;
194 
195 exp	:	ABS '(' exp ')'
196 			{ write_exp_elt_opcode (pstate, UNOP_ABS); }
197 	;
198 
199 exp	: 	HIGH '(' exp ')'
200 			{ write_exp_elt_opcode (pstate, UNOP_HIGH); }
201 	;
202 
203 exp 	:	MIN_FUNC '(' type ')'
204 			{ write_exp_elt_opcode (pstate, UNOP_MIN);
205 			  write_exp_elt_type (pstate, $3);
206 			  write_exp_elt_opcode (pstate, UNOP_MIN); }
207 	;
208 
209 exp	: 	MAX_FUNC '(' type ')'
210 			{ write_exp_elt_opcode (pstate, UNOP_MAX);
211 			  write_exp_elt_type (pstate, $3);
212 			  write_exp_elt_opcode (pstate, UNOP_MAX); }
213 	;
214 
215 exp	:	FLOAT_FUNC '(' exp ')'
216 			{ write_exp_elt_opcode (pstate, UNOP_FLOAT); }
217 	;
218 
219 exp	:	VAL '(' type ',' exp ')'
220 			{ write_exp_elt_opcode (pstate, BINOP_VAL);
221 			  write_exp_elt_type (pstate, $3);
222 			  write_exp_elt_opcode (pstate, BINOP_VAL); }
223 	;
224 
225 exp	:	CHR '(' exp ')'
226 			{ write_exp_elt_opcode (pstate, UNOP_CHR); }
227 	;
228 
229 exp	:	ODD '(' exp ')'
230 			{ write_exp_elt_opcode (pstate, UNOP_ODD); }
231 	;
232 
233 exp	:	TRUNC '(' exp ')'
234 			{ write_exp_elt_opcode (pstate, UNOP_TRUNC); }
235 	;
236 
237 exp	:	TSIZE '(' exp ')'
238 			{ write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
239 	;
240 
241 exp	:	SIZE exp       %prec UNARY
242 			{ write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
243 	;
244 
245 
246 exp	:	INC '(' exp ')'
247 			{ write_exp_elt_opcode (pstate, UNOP_PREINCREMENT); }
248 	;
249 
250 exp	:	INC '(' exp ',' exp ')'
251 			{ write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
252 			  write_exp_elt_opcode (pstate, BINOP_ADD);
253 			  write_exp_elt_opcode (pstate,
254 						BINOP_ASSIGN_MODIFY); }
255 	;
256 
257 exp	:	DEC '(' exp ')'
258 			{ write_exp_elt_opcode (pstate, UNOP_PREDECREMENT);}
259 	;
260 
261 exp	:	DEC '(' exp ',' exp ')'
262 			{ write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
263 			  write_exp_elt_opcode (pstate, BINOP_SUB);
264 			  write_exp_elt_opcode (pstate,
265 						BINOP_ASSIGN_MODIFY); }
266 	;
267 
268 exp	:	exp DOT NAME
269 			{ write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
270 			  write_exp_string (pstate, $3);
271 			  write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
272 	;
273 
274 exp	:	set
275 	;
276 
277 exp	:	exp IN set
278 			{ error (_("Sets are not implemented."));}
279 	;
280 
281 exp	:	INCL '(' exp ',' exp ')'
282 			{ error (_("Sets are not implemented."));}
283 	;
284 
285 exp	:	EXCL '(' exp ',' exp ')'
286 			{ error (_("Sets are not implemented."));}
287 	;
288 
289 set	:	'{' arglist '}'
290 			{ error (_("Sets are not implemented."));}
291 	|	type '{' arglist '}'
292 			{ error (_("Sets are not implemented."));}
293 	;
294 
295 
296 /* Modula-2 array subscript notation [a,b,c...].  */
297 exp     :       exp '['
298                         /* This function just saves the number of arguments
299 			   that follow in the list.  It is *not* specific to
300 			   function types */
301                         { pstate->start_arglist(); }
302                 non_empty_arglist ']'  %prec DOT
303 			{
304 			  gdb_assert (pstate->arglist_len > 0);
305 			  write_exp_elt_opcode (pstate, MULTI_SUBSCRIPT);
306 			  write_exp_elt_longcst (pstate,
307 						 pstate->end_arglist());
308 			  write_exp_elt_opcode (pstate, MULTI_SUBSCRIPT);
309 			}
310 	;
311 
312 exp	:	exp '('
313 			/* This is to save the value of arglist_len
314 			   being accumulated by an outer function call.  */
315 			{ pstate->start_arglist (); }
316 		arglist ')'	%prec DOT
317 			{ write_exp_elt_opcode (pstate, OP_FUNCALL);
318 			  write_exp_elt_longcst (pstate,
319 						 pstate->end_arglist ());
320 			  write_exp_elt_opcode (pstate, OP_FUNCALL); }
321 	;
322 
323 arglist	:
324 	;
325 
326 arglist	:	exp
327 			{ pstate->arglist_len = 1; }
328 	;
329 
330 arglist	:	arglist ',' exp   %prec ABOVE_COMMA
331 			{ pstate->arglist_len++; }
332 	;
333 
334 non_empty_arglist
335         :       exp
336                         { pstate->arglist_len = 1; }
337 	;
338 
339 non_empty_arglist
340         :       non_empty_arglist ',' exp %prec ABOVE_COMMA
341      	       	    	{ pstate->arglist_len++; }
342      	;
343 
344 /* GDB construct */
345 exp	:	'{' type '}' exp  %prec UNARY
346 			{ write_exp_elt_opcode (pstate, UNOP_MEMVAL);
347 			  write_exp_elt_type (pstate, $2);
348 			  write_exp_elt_opcode (pstate, UNOP_MEMVAL); }
349 	;
350 
351 exp     :       type '(' exp ')' %prec UNARY
352                         { write_exp_elt_opcode (pstate, UNOP_CAST);
353 			  write_exp_elt_type (pstate, $1);
354 			  write_exp_elt_opcode (pstate, UNOP_CAST); }
355 	;
356 
357 exp	:	'(' exp ')'
358 			{ }
359 	;
360 
361 /* Binary operators in order of decreasing precedence.  Note that some
362    of these operators are overloaded!  (ie. sets) */
363 
364 /* GDB construct */
365 exp	:	exp '@' exp
366 			{ write_exp_elt_opcode (pstate, BINOP_REPEAT); }
367 	;
368 
369 exp	:	exp '*' exp
370 			{ write_exp_elt_opcode (pstate, BINOP_MUL); }
371 	;
372 
373 exp	:	exp '/' exp
374 			{ write_exp_elt_opcode (pstate, BINOP_DIV); }
375 	;
376 
377 exp     :       exp DIV exp
378                         { write_exp_elt_opcode (pstate, BINOP_INTDIV); }
379         ;
380 
381 exp	:	exp MOD exp
382 			{ write_exp_elt_opcode (pstate, BINOP_REM); }
383 	;
384 
385 exp	:	exp '+' exp
386 			{ write_exp_elt_opcode (pstate, BINOP_ADD); }
387 	;
388 
389 exp	:	exp '-' exp
390 			{ write_exp_elt_opcode (pstate, BINOP_SUB); }
391 	;
392 
393 exp	:	exp '=' exp
394 			{ write_exp_elt_opcode (pstate, BINOP_EQUAL); }
395 	;
396 
397 exp	:	exp NOTEQUAL exp
398 			{ write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
399         |       exp '#' exp
400                         { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
401 	;
402 
403 exp	:	exp LEQ exp
404 			{ write_exp_elt_opcode (pstate, BINOP_LEQ); }
405 	;
406 
407 exp	:	exp GEQ exp
408 			{ write_exp_elt_opcode (pstate, BINOP_GEQ); }
409 	;
410 
411 exp	:	exp '<' exp
412 			{ write_exp_elt_opcode (pstate, BINOP_LESS); }
413 	;
414 
415 exp	:	exp '>' exp
416 			{ write_exp_elt_opcode (pstate, BINOP_GTR); }
417 	;
418 
419 exp	:	exp LOGICAL_AND exp
420 			{ write_exp_elt_opcode (pstate, BINOP_LOGICAL_AND); }
421 	;
422 
423 exp	:	exp OROR exp
424 			{ write_exp_elt_opcode (pstate, BINOP_LOGICAL_OR); }
425 	;
426 
427 exp	:	exp ASSIGN exp
428 			{ write_exp_elt_opcode (pstate, BINOP_ASSIGN); }
429 	;
430 
431 
432 /* Constants */
433 
434 exp	:	M2_TRUE
435 			{ write_exp_elt_opcode (pstate, OP_BOOL);
436 			  write_exp_elt_longcst (pstate, (LONGEST) $1);
437 			  write_exp_elt_opcode (pstate, OP_BOOL); }
438 	;
439 
440 exp	:	M2_FALSE
441 			{ write_exp_elt_opcode (pstate, OP_BOOL);
442 			  write_exp_elt_longcst (pstate, (LONGEST) $1);
443 			  write_exp_elt_opcode (pstate, OP_BOOL); }
444 	;
445 
446 exp	:	INT
447 			{ write_exp_elt_opcode (pstate, OP_LONG);
448 			  write_exp_elt_type (pstate,
449 					parse_m2_type (pstate)->builtin_int);
450 			  write_exp_elt_longcst (pstate, (LONGEST) $1);
451 			  write_exp_elt_opcode (pstate, OP_LONG); }
452 	;
453 
454 exp	:	UINT
455 			{
456 			  write_exp_elt_opcode (pstate, OP_LONG);
457 			  write_exp_elt_type (pstate,
458 					      parse_m2_type (pstate)
459 					      ->builtin_card);
460 			  write_exp_elt_longcst (pstate, (LONGEST) $1);
461 			  write_exp_elt_opcode (pstate, OP_LONG);
462 			}
463 	;
464 
465 exp	:	CHAR
466 			{ write_exp_elt_opcode (pstate, OP_LONG);
467 			  write_exp_elt_type (pstate,
468 					      parse_m2_type (pstate)
469 					      ->builtin_char);
470 			  write_exp_elt_longcst (pstate, (LONGEST) $1);
471 			  write_exp_elt_opcode (pstate, OP_LONG); }
472 	;
473 
474 
475 exp	:	FLOAT
476 			{ write_exp_elt_opcode (pstate, OP_FLOAT);
477 			  write_exp_elt_type (pstate,
478 					      parse_m2_type (pstate)
479 					      ->builtin_real);
480 			  write_exp_elt_floatcst (pstate, $1);
481 			  write_exp_elt_opcode (pstate, OP_FLOAT); }
482 	;
483 
484 exp	:	variable
485 	;
486 
487 exp	:	SIZE '(' type ')'	%prec UNARY
488 			{ write_exp_elt_opcode (pstate, OP_LONG);
489 			  write_exp_elt_type (pstate,
490 					    parse_type (pstate)->builtin_int);
491 			  write_exp_elt_longcst (pstate,
492 						 (LONGEST) TYPE_LENGTH ($3));
493 			  write_exp_elt_opcode (pstate, OP_LONG); }
494 	;
495 
496 exp	:	STRING
497 			{ write_exp_elt_opcode (pstate, OP_M2_STRING);
498 			  write_exp_string (pstate, $1);
499 			  write_exp_elt_opcode (pstate, OP_M2_STRING); }
500 	;
501 
502 /* This will be used for extensions later.  Like adding modules.  */
503 block	:	fblock
504 			{ $$ = SYMBOL_BLOCK_VALUE($1); }
505 	;
506 
507 fblock	:	BLOCKNAME
508 			{ struct symbol *sym
509 			    = lookup_symbol (copy_name ($1).c_str (),
510 					     pstate->expression_context_block,
511 					     VAR_DOMAIN, 0).symbol;
512 			  $$ = sym;}
513 	;
514 
515 
516 /* GDB scope operator */
517 fblock	:	block COLONCOLON BLOCKNAME
518 			{ struct symbol *tem
519 			    = lookup_symbol (copy_name ($3).c_str (), $1,
520 					     VAR_DOMAIN, 0).symbol;
521 			  if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
522 			    error (_("No function \"%s\" in specified context."),
523 				   copy_name ($3).c_str ());
524 			  $$ = tem;
525 			}
526 	;
527 
528 /* Useful for assigning to PROCEDURE variables */
529 variable:	fblock
530 			{ write_exp_elt_opcode (pstate, OP_VAR_VALUE);
531 			  write_exp_elt_block (pstate, NULL);
532 			  write_exp_elt_sym (pstate, $1);
533 			  write_exp_elt_opcode (pstate, OP_VAR_VALUE); }
534 	;
535 
536 /* GDB internal ($foo) variable */
537 variable:	DOLLAR_VARIABLE
538 	;
539 
540 /* GDB scope operator */
541 variable:	block COLONCOLON NAME
542 			{ struct block_symbol sym
543 			    = lookup_symbol (copy_name ($3).c_str (), $1,
544 					     VAR_DOMAIN, 0);
545 
546 			  if (sym.symbol == 0)
547 			    error (_("No symbol \"%s\" in specified context."),
548 				   copy_name ($3).c_str ());
549 			  if (symbol_read_needs_frame (sym.symbol))
550 			    pstate->block_tracker->update (sym);
551 
552 			  write_exp_elt_opcode (pstate, OP_VAR_VALUE);
553 			  write_exp_elt_block (pstate, sym.block);
554 			  write_exp_elt_sym (pstate, sym.symbol);
555 			  write_exp_elt_opcode (pstate, OP_VAR_VALUE); }
556 	;
557 
558 /* Base case for variables.  */
559 variable:	NAME
560 			{ struct block_symbol sym;
561 			  struct field_of_this_result is_a_field_of_this;
562 
563 			  sym
564 			    = lookup_symbol (copy_name ($1).c_str (),
565 					     pstate->expression_context_block,
566 					     VAR_DOMAIN,
567 					     &is_a_field_of_this);
568 
569 			  if (sym.symbol)
570 			    {
571 			      if (symbol_read_needs_frame (sym.symbol))
572 				pstate->block_tracker->update (sym);
573 
574 			      write_exp_elt_opcode (pstate, OP_VAR_VALUE);
575 			      write_exp_elt_block (pstate, sym.block);
576 			      write_exp_elt_sym (pstate, sym.symbol);
577 			      write_exp_elt_opcode (pstate, OP_VAR_VALUE);
578 			    }
579 			  else
580 			    {
581 			      struct bound_minimal_symbol msymbol;
582 			      std::string arg = copy_name ($1);
583 
584 			      msymbol =
585 				lookup_bound_minimal_symbol (arg.c_str ());
586 			      if (msymbol.minsym != NULL)
587 				write_exp_msymbol (pstate, msymbol);
588 			      else if (!have_full_symbols () && !have_partial_symbols ())
589 				error (_("No symbol table is loaded.  Use the \"symbol-file\" command."));
590 			      else
591 				error (_("No symbol \"%s\" in current context."),
592 				       arg.c_str ());
593 			    }
594 			}
595 	;
596 
597 type
598 	:	TYPENAME
599 			{ $$
600 			    = lookup_typename (pstate->language (),
601 					       copy_name ($1).c_str (),
602 					       pstate->expression_context_block,
603 					       0);
604 			}
605 
606 	;
607 
608 %%
609 
610 /* Take care of parsing a number (anything that starts with a digit).
611    Set yylval and return the token type; update lexptr.
612    LEN is the number of characters in it.  */
613 
614 /*** Needs some error checking for the float case ***/
615 
616 static int
617 parse_number (int olen)
618 {
619   const char *p = pstate->lexptr;
620   LONGEST n = 0;
621   LONGEST prevn = 0;
622   int c,i,ischar=0;
623   int base = input_radix;
624   int len = olen;
625   int unsigned_p = number_sign == 1 ? 1 : 0;
626 
627   if(p[len-1] == 'H')
628   {
629      base = 16;
630      len--;
631   }
632   else if(p[len-1] == 'C' || p[len-1] == 'B')
633   {
634      base = 8;
635      ischar = p[len-1] == 'C';
636      len--;
637   }
638 
639   /* Scan the number */
640   for (c = 0; c < len; c++)
641   {
642     if (p[c] == '.' && base == 10)
643       {
644 	/* It's a float since it contains a point.  */
645 	if (!parse_float (p, len,
646 			  parse_m2_type (pstate)->builtin_real,
647 			  yylval.val))
648 	  return ERROR;
649 
650 	pstate->lexptr += len;
651 	return FLOAT;
652       }
653     if (p[c] == '.' && base != 10)
654        error (_("Floating point numbers must be base 10."));
655     if (base == 10 && (p[c] < '0' || p[c] > '9'))
656        error (_("Invalid digit \'%c\' in number."),p[c]);
657  }
658 
659   while (len-- > 0)
660     {
661       c = *p++;
662       n *= base;
663       if( base == 8 && (c == '8' || c == '9'))
664 	 error (_("Invalid digit \'%c\' in octal number."),c);
665       if (c >= '0' && c <= '9')
666 	i = c - '0';
667       else
668 	{
669 	  if (base == 16 && c >= 'A' && c <= 'F')
670 	    i = c - 'A' + 10;
671 	  else
672 	     return ERROR;
673 	}
674       n+=i;
675       if(i >= base)
676 	 return ERROR;
677       if(!unsigned_p && number_sign == 1 && (prevn >= n))
678 	 unsigned_p=1;		/* Try something unsigned */
679       /* Don't do the range check if n==i and i==0, since that special
680 	 case will give an overflow error.  */
681       if(RANGE_CHECK && n!=i && i)
682       {
683 	 if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
684 	    ((!unsigned_p && number_sign==-1) && -prevn <= -n))
685 	    range_error (_("Overflow on numeric constant."));
686       }
687 	 prevn=n;
688     }
689 
690   pstate->lexptr = p;
691   if(*p == 'B' || *p == 'C' || *p == 'H')
692      pstate->lexptr++;			/* Advance past B,C or H */
693 
694   if (ischar)
695   {
696      yylval.ulval = n;
697      return CHAR;
698   }
699   else if ( unsigned_p && number_sign == 1)
700   {
701      yylval.ulval = n;
702      return UINT;
703   }
704   else if((unsigned_p && (n<0))) {
705      range_error (_("Overflow on numeric constant -- number too large."));
706      /* But, this can return if range_check == range_warn.  */
707   }
708   yylval.lval = n;
709   return INT;
710 }
711 
712 
713 /* Some tokens */
714 
715 static struct
716 {
717    char name[2];
718    int token;
719 } tokentab2[] =
720 {
721     { {'<', '>'},    NOTEQUAL 	},
722     { {':', '='},    ASSIGN	},
723     { {'<', '='},    LEQ	},
724     { {'>', '='},    GEQ	},
725     { {':', ':'},    COLONCOLON },
726 
727 };
728 
729 /* Some specific keywords */
730 
731 struct keyword {
732    char keyw[10];
733    int token;
734 };
735 
736 static struct keyword keytab[] =
737 {
738     {"OR" ,   OROR	 },
739     {"IN",    IN         },/* Note space after IN */
740     {"AND",   LOGICAL_AND},
741     {"ABS",   ABS	 },
742     {"CHR",   CHR	 },
743     {"DEC",   DEC	 },
744     {"NOT",   NOT	 },
745     {"DIV",   DIV    	 },
746     {"INC",   INC	 },
747     {"MAX",   MAX_FUNC	 },
748     {"MIN",   MIN_FUNC	 },
749     {"MOD",   MOD	 },
750     {"ODD",   ODD	 },
751     {"CAP",   CAP	 },
752     {"ORD",   ORD	 },
753     {"VAL",   VAL	 },
754     {"EXCL",  EXCL	 },
755     {"HIGH",  HIGH       },
756     {"INCL",  INCL	 },
757     {"SIZE",  SIZE       },
758     {"FLOAT", FLOAT_FUNC },
759     {"TRUNC", TRUNC	 },
760     {"TSIZE", SIZE       },
761 };
762 
763 
764 /* Depth of parentheses.  */
765 static int paren_depth;
766 
767 /* Read one token, getting characters through lexptr.  */
768 
769 /* This is where we will check to make sure that the language and the
770    operators used are compatible  */
771 
772 static int
773 yylex (void)
774 {
775   int c;
776   int namelen;
777   int i;
778   const char *tokstart;
779   char quote;
780 
781  retry:
782 
783   pstate->prev_lexptr = pstate->lexptr;
784 
785   tokstart = pstate->lexptr;
786 
787 
788   /* See if it is a special token of length 2 */
789   for( i = 0 ; i < (int) (sizeof tokentab2 / sizeof tokentab2[0]) ; i++)
790      if (strncmp (tokentab2[i].name, tokstart, 2) == 0)
791      {
792 	pstate->lexptr += 2;
793 	return tokentab2[i].token;
794      }
795 
796   switch (c = *tokstart)
797     {
798     case 0:
799       return 0;
800 
801     case ' ':
802     case '\t':
803     case '\n':
804       pstate->lexptr++;
805       goto retry;
806 
807     case '(':
808       paren_depth++;
809       pstate->lexptr++;
810       return c;
811 
812     case ')':
813       if (paren_depth == 0)
814 	return 0;
815       paren_depth--;
816       pstate->lexptr++;
817       return c;
818 
819     case ',':
820       if (pstate->comma_terminates && paren_depth == 0)
821 	return 0;
822       pstate->lexptr++;
823       return c;
824 
825     case '.':
826       /* Might be a floating point number.  */
827       if (pstate->lexptr[1] >= '0' && pstate->lexptr[1] <= '9')
828 	break;			/* Falls into number code.  */
829       else
830       {
831 	 pstate->lexptr++;
832 	 return DOT;
833       }
834 
835 /* These are character tokens that appear as-is in the YACC grammar */
836     case '+':
837     case '-':
838     case '*':
839     case '/':
840     case '^':
841     case '<':
842     case '>':
843     case '[':
844     case ']':
845     case '=':
846     case '{':
847     case '}':
848     case '#':
849     case '@':
850     case '~':
851     case '&':
852       pstate->lexptr++;
853       return c;
854 
855     case '\'' :
856     case '"':
857       quote = c;
858       for (namelen = 1; (c = tokstart[namelen]) != quote && c != '\0'; namelen++)
859 	if (c == '\\')
860 	  {
861 	    c = tokstart[++namelen];
862 	    if (c >= '0' && c <= '9')
863 	      {
864 		c = tokstart[++namelen];
865 		if (c >= '0' && c <= '9')
866 		  c = tokstart[++namelen];
867 	      }
868 	  }
869       if(c != quote)
870 	 error (_("Unterminated string or character constant."));
871       yylval.sval.ptr = tokstart + 1;
872       yylval.sval.length = namelen - 1;
873       pstate->lexptr += namelen + 1;
874 
875       if(namelen == 2)  	/* Single character */
876       {
877 	   yylval.ulval = tokstart[1];
878 	   return CHAR;
879       }
880       else
881 	 return STRING;
882     }
883 
884   /* Is it a number?  */
885   /* Note:  We have already dealt with the case of the token '.'.
886      See case '.' above.  */
887   if ((c >= '0' && c <= '9'))
888     {
889       /* It's a number.  */
890       int got_dot = 0, got_e = 0;
891       const char *p = tokstart;
892       int toktype;
893 
894       for (++p ;; ++p)
895 	{
896 	  if (!got_e && (*p == 'e' || *p == 'E'))
897 	    got_dot = got_e = 1;
898 	  else if (!got_dot && *p == '.')
899 	    got_dot = 1;
900 	  else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
901 		   && (*p == '-' || *p == '+'))
902 	    /* This is the sign of the exponent, not the end of the
903 	       number.  */
904 	    continue;
905 	  else if ((*p < '0' || *p > '9') &&
906 		   (*p < 'A' || *p > 'F') &&
907 		   (*p != 'H'))  /* Modula-2 hexadecimal number */
908 	    break;
909 	}
910 	toktype = parse_number (p - tokstart);
911         if (toktype == ERROR)
912 	  {
913 	    char *err_copy = (char *) alloca (p - tokstart + 1);
914 
915 	    memcpy (err_copy, tokstart, p - tokstart);
916 	    err_copy[p - tokstart] = 0;
917 	    error (_("Invalid number \"%s\"."), err_copy);
918 	  }
919 	pstate->lexptr = p;
920 	return toktype;
921     }
922 
923   if (!(c == '_' || c == '$'
924 	|| (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
925     /* We must have come across a bad character (e.g. ';').  */
926     error (_("Invalid character '%c' in expression."), c);
927 
928   /* It's a name.  See how long it is.  */
929   namelen = 0;
930   for (c = tokstart[namelen];
931        (c == '_' || c == '$' || (c >= '0' && c <= '9')
932 	|| (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
933        c = tokstart[++namelen])
934     ;
935 
936   /* The token "if" terminates the expression and is NOT
937      removed from the input stream.  */
938   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
939     {
940       return 0;
941     }
942 
943   pstate->lexptr += namelen;
944 
945   /*  Lookup special keywords */
946   for(i = 0 ; i < (int) (sizeof(keytab) / sizeof(keytab[0])) ; i++)
947      if (namelen == strlen (keytab[i].keyw)
948 	 && strncmp (tokstart, keytab[i].keyw, namelen) == 0)
949 	   return keytab[i].token;
950 
951   yylval.sval.ptr = tokstart;
952   yylval.sval.length = namelen;
953 
954   if (*tokstart == '$')
955     {
956       write_dollar_variable (pstate, yylval.sval);
957       return DOLLAR_VARIABLE;
958     }
959 
960   /* Use token-type BLOCKNAME for symbols that happen to be defined as
961      functions.  If this is not so, then ...
962      Use token-type TYPENAME for symbols that happen to be defined
963      currently as names of types; NAME for other symbols.
964      The caller is not constrained to care about the distinction.  */
965  {
966     std::string tmp = copy_name (yylval.sval);
967     struct symbol *sym;
968 
969     if (lookup_symtab (tmp.c_str ()))
970       return BLOCKNAME;
971     sym = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
972 			 VAR_DOMAIN, 0).symbol;
973     if (sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
974       return BLOCKNAME;
975     if (lookup_typename (pstate->language (),
976 			 tmp.c_str (), pstate->expression_context_block, 1))
977       return TYPENAME;
978 
979     if(sym)
980     {
981       switch(SYMBOL_CLASS (sym))
982        {
983        case LOC_STATIC:
984        case LOC_REGISTER:
985        case LOC_ARG:
986        case LOC_REF_ARG:
987        case LOC_REGPARM_ADDR:
988        case LOC_LOCAL:
989        case LOC_CONST:
990        case LOC_CONST_BYTES:
991        case LOC_OPTIMIZED_OUT:
992        case LOC_COMPUTED:
993 	  return NAME;
994 
995        case LOC_TYPEDEF:
996 	  return TYPENAME;
997 
998        case LOC_BLOCK:
999 	  return BLOCKNAME;
1000 
1001        case LOC_UNDEF:
1002 	  error (_("internal:  Undefined class in m2lex()"));
1003 
1004        case LOC_LABEL:
1005        case LOC_UNRESOLVED:
1006 	  error (_("internal:  Unforseen case in m2lex()"));
1007 
1008        default:
1009 	  error (_("unhandled token in m2lex()"));
1010 	  break;
1011        }
1012     }
1013     else
1014     {
1015        /* Built-in BOOLEAN type.  This is sort of a hack.  */
1016        if (strncmp (tokstart, "TRUE", 4) == 0)
1017        {
1018 	  yylval.ulval = 1;
1019 	  return M2_TRUE;
1020        }
1021        else if (strncmp (tokstart, "FALSE", 5) == 0)
1022        {
1023 	  yylval.ulval = 0;
1024 	  return M2_FALSE;
1025        }
1026     }
1027 
1028     /* Must be another type of name...  */
1029     return NAME;
1030  }
1031 }
1032 
1033 int
1034 m2_parse (struct parser_state *par_state)
1035 {
1036   /* Setting up the parser state.  */
1037   scoped_restore pstate_restore = make_scoped_restore (&pstate);
1038   gdb_assert (par_state != NULL);
1039   pstate = par_state;
1040   paren_depth = 0;
1041 
1042   return yyparse ();
1043 }
1044 
1045 static void
1046 yyerror (const char *msg)
1047 {
1048   if (pstate->prev_lexptr)
1049     pstate->lexptr = pstate->prev_lexptr;
1050 
1051   error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);
1052 }
1053