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