Subversion Repositories tendra.SVN

Rev

Rev 2 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 7u83 1
/*
2
    		 Crown Copyright (c) 1997, 1998
3
 
4
    This TenDRA(r) Computer Program is subject to Copyright
5
    owned by the United Kingdom Secretary of State for Defence
6
    acting through the Defence Evaluation and Research Agency
7
    (DERA).  It is made available to Recipients with a
8
    royalty-free licence for its use, reproduction, transfer
9
    to other parties and amendment for any purpose not excluding
10
    product development provided that any such use et cetera
11
    shall be deemed to be acceptance of the following conditions:-
12
 
13
        (1) Its Recipients shall ensure that this Notice is
14
        reproduced upon any copies or amended versions of it;
15
 
16
        (2) Any amended version of it shall be clearly marked to
17
        show both the nature of and the organisation responsible
18
        for the relevant amendment or amendments;
19
 
20
        (3) Its onward transfer from a recipient to another
21
        party shall be deemed to be that party's acceptance of
22
        these conditions;
23
 
24
        (4) DERA gives no warranty or assurance as to its
25
        quality or suitability for any purpose and DERA accepts
26
        no liability whatsoever in relation to any use to which
27
        it may be put.
28
*/
29
 
30
 
31
#include "config.h"
32
#include <limits.h>
33
#include "c_types.h"
34
#include "ctype_ops.h"
35
#include "exp_ops.h"
36
#include "hashid_ops.h"
37
#include "id_ops.h"
38
#include "member_ops.h"
39
#include "nat_ops.h"
40
#include "nspace_ops.h"
41
#include "off_ops.h"
42
#include "tok_ops.h"
43
#include "type_ops.h"
44
#include "error.h"
45
#include "catalog.h"
46
#include "option.h"
47
#include "access.h"
48
#include "basetype.h"
49
#include "check.h"
50
#include "chktype.h"
51
#include "class.h"
52
#include "constant.h"
53
#include "convert.h"
54
#include "derive.h"
55
#include "dump.h"
56
#include "exception.h"
57
#include "expression.h"
58
#include "file.h"
59
#include "function.h"
60
#include "hash.h"
61
#include "identifier.h"
62
#include "initialise.h"
63
#include "inttype.h"
64
#include "lex.h"
65
#include "macro.h"
66
#include "member.h"
67
#include "namespace.h"
68
#include "overload.h"
69
#include "parse.h"
70
#include "predict.h"
71
#include "preproc.h"
72
#include "redeclare.h"
73
#include "statement.h"
74
#include "syntax.h"
75
#include "template.h"
76
#include "tokdef.h"
77
#include "token.h"
78
 
79
 
80
/*
81
    TOKEN DEFINITION FLAG
82
 
83
    Tokens are defined by the equality routines if the flag force_tokdef
84
    is set.  This is only done if we are reasonably sure that the equality
85
    should hold.  Similarly template specialisation is only considered
86
    if force_template is true.
87
*/
88
 
89
int force_tokdef = 0 ;
90
int force_template = 0 ;
91
int expand_tokdef = 0 ;
92
 
93
 
94
/*
95
    IS A TOKEN BEING DEFINED?
96
 
97
    This routine uses the values force_tokdef and force_template to
98
    determine whether the token id is available for token unification.
99
*/
100
 
101
int defining_token
102
    PROTO_N ( ( id ) )
103
    PROTO_T ( IDENTIFIER id )
104
{
105
    if ( !IS_NULL_id ( id ) && IS_id_token ( id ) ) {
106
	DECL_SPEC ds ;
107
	if ( force_tokdef ) return ( 1 ) ;
108
	ds = DEREF_dspec ( id_storage ( id ) ) ;
109
	if ( ds & dspec_template ) return ( force_template ) ;
110
    }
111
    return ( 0 ) ;
112
}
113
 
114
 
115
/*
116
    FIND THE RESULT COMPONENT OF A TOKEN
117
 
118
    This routine finds the result component of the token id.
119
*/
120
 
121
TOKEN find_tokdef
122
    PROTO_N ( ( id ) )
123
    PROTO_T ( IDENTIFIER id )
124
{
125
    TOKEN tok = NULL_tok ;
126
    if ( !IS_NULL_id ( id ) && IS_id_token ( id ) ) {
127
	unsigned tag ;
128
	tok = DEREF_tok ( id_token_sort ( id ) ) ;
129
	tag = TAG_tok ( tok ) ;
130
	if ( tag == tok_func_tag ) {
131
	    TOKEN ptok = DEREF_tok ( tok_func_proc ( tok ) ) ;
132
	    if ( !IS_NULL_tok ( ptok ) ) {
133
		tok = DEREF_tok ( tok_proc_res ( ptok ) ) ;
134
	    }
135
	} else if ( tag == tok_proc_tag ) {
136
	    tok = DEREF_tok ( tok_proc_res ( tok ) ) ;
137
	}
138
    }
139
    return ( tok ) ;
140
}
141
 
142
 
143
/*
144
    DUMMY TOKEN PARAMETER VALUES
145
 
146
    These values are used to indicate that a token parameter has been
147
    redefined inconsistently.
148
*/
149
 
150
static NAT redef_nat = NULL_nat ;
151
static EXP redef_exp = NULL_exp ;
152
TYPE redef_type = NULL_type ;
153
static IDENTIFIER redef_id = NULL_id ;
154
static OFFSET redef_off = NULL_off ;
155
 
156
 
157
/*
158
    INITIALISE DUMMY TOKEN PARAMETER VALUES
159
 
160
    This routine initialises the dummy token parameter values above.
161
    They are set to impossible values which could not arise naturally.
162
*/
163
 
164
void init_token_args
165
    PROTO_Z ()
166
{
167
    HASHID nm = KEYWORD ( lex_error ) ;
168
    redef_id = DEREF_id ( hashid_id ( nm ) ) ;
169
    MAKE_type_ref ( cv_none, type_void, redef_type ) ;
170
    MAKE_exp_value ( redef_type, redef_exp ) ;
171
    MAKE_nat_calc ( redef_exp, redef_nat ) ;
172
    MAKE_off_zero ( redef_type, redef_off ) ;
173
    return ;
174
}
175
 
176
 
177
/*
178
    DEFINE AN INTEGER CONSTANT TOKEN
179
 
180
    This routine defines the integer constant token id to be e.  It
181
    returns true if the token is assigned a value.
182
*/
183
 
184
int define_nat_token
185
    PROTO_N ( ( id, n ) )
186
    PROTO_T ( IDENTIFIER id X NAT n )
187
{
188
    if ( !IS_NULL_nat ( n ) ) {
189
	DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
190
	if ( !( ds & dspec_pure ) ) {
191
	    int ok = 1 ;
192
	    TOKEN tok = find_tokdef ( id ) ;
193
	    if ( IS_NULL_tok ( tok ) ) return ( 0 ) ;
194
	    switch ( TAG_tok ( tok ) ) {
195
		case tok_nat_tag :
196
		case tok_snat_tag : {
197
		    /* Integer constant tokens */
198
		    NAT m = DEREF_nat ( tok_nat_etc_value ( tok ) ) ;
199
		    if ( !IS_NULL_nat ( m ) && !eq_nat ( n, m ) ) {
200
			if ( ds & dspec_auto ) {
201
			    n = redef_nat ;
202
			} else {
203
			    PTR ( LOCATION ) loc = id_loc ( id ) ;
204
			    report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
205
			}
206
			ok = 0 ;
207
		    }
208
		    COPY_nat ( tok_nat_etc_value ( tok ), n ) ;
209
		    break ;
210
		}
211
		case tok_exp_tag :
212
		case tok_stmt_tag : {
213
		    /* Expression tokens */
214
		    EXP e = calc_nat_value ( n, type_sint ) ;
215
		    return ( define_exp_token ( id, e, 1 ) ) ;
216
		}
217
		default : {
218
		    /* Other tokens */
219
		    return ( 0 ) ;
220
		}
221
	    }
222
	    if ( !( ds & dspec_auto ) ) no_token_defns++ ;
223
	    ds |= dspec_defn ;
224
	    COPY_dspec ( id_storage ( id ), ds ) ;
225
	    COPY_loc ( id_loc ( id ), crt_loc ) ;
226
	    return ( ok ) ;
227
	}
228
    }
229
    return ( 0 ) ;
230
}
231
 
232
 
233
/*
234
    DEFINE AN EXPRESSION TOKEN
235
 
236
    This routine defines the expression, statement or integer constant
237
    token id to be e.  It returns true if the token is assigned a value.
238
    expl is false for an enforcing external declaration, such as that
239
    arising from unify_id.
240
*/
241
 
242
int define_exp_token
243
    PROTO_N ( ( id, e, expl ) )
244
    PROTO_T ( IDENTIFIER id X EXP e X int expl )
245
{
246
    if ( !IS_NULL_exp ( e ) ) {
247
	DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
248
	if ( !( ds & dspec_pure ) ) {
249
	    int ok = 1 ;
250
	    unsigned tt ;
251
	    TOKEN tok = find_tokdef ( id ) ;
252
	    if ( IS_NULL_tok ( tok ) ) return ( 0 ) ;
253
	    tt = TAG_tok ( tok ) ;
254
	    switch ( tt ) {
255
 
256
		case tok_exp_tag : {
257
		    /* Expression tokens */
258
		    TYPE s ;
259
		    ERROR err = NULL_err ;
260
		    unsigned etag = TAG_exp ( e ) ;
261
		    EXP d = DEREF_exp ( tok_exp_value ( tok ) ) ;
262
		    int c = DEREF_int ( tok_exp_constant ( tok ) ) ;
263
		    TYPE t = DEREF_type ( tok_exp_type ( tok ) ) ;
264
		    CV_SPEC cv = DEREF_cv ( type_qual ( t ) ) ;
265
		    LIST ( IDENTIFIER ) pids = NULL_list ( IDENTIFIER ) ;
266
		    force_tokdef++ ;
267
		    e = convert_reference ( e, REF_ASSIGN ) ;
268
		    e = resolve_cast ( t, e, &err, 1, 0, pids ) ;
269
		    s = DEREF_type ( exp_type ( e ) ) ;
270
		    if ( cv & cv_lvalue ) {
271
			/* lvalue tokens */
272
			cv = DEREF_cv ( type_qual ( s ) ) ;
273
			if ( cv & cv_lvalue ) {
274
			    if ( eq_type ( s, t ) ) {
275
				if ( !IS_exp_address ( e ) ) {
276
				    MAKE_exp_address ( t, e, e ) ;
277
				}
278
			    } else {
279
				EXP a = init_ref_lvalue ( t, e, &err ) ;
280
				if ( IS_NULL_exp ( a ) ) {
281
				    err = ERR_basic_link_incompat ( t, s ) ;
282
				} else {
283
				    e = make_ref_init ( t, a ) ;
284
				}
285
			    }
286
			} else {
287
			    report ( crt_loc, ERR_token_arg_lvalue ( id ) ) ;
288
			}
289
		    } else {
290
			/* rvalue tokens */
291
			if ( IS_exp_aggregate ( e ) ) {
292
			    /* Aggregate initialiser */
293
			    e = init_aggregate ( t, e, id, &err ) ;
294
			} else {
295
			    switch ( TAG_type ( t ) ) {
296
				case type_top_tag :
297
				case type_bottom_tag : {
298
				    /* Void expressions */
299
				    e = convert_lvalue ( e ) ;
300
				    e = convert_none ( e ) ;
301
				    e = make_discard_exp ( e ) ;
302
				    if ( !IS_type_top_etc ( s ) ) {
303
					EXP a = make_null_exp ( t ) ;
304
					e = join_exp ( e, a ) ;
305
				    }
306
				    break ;
307
				}
308
				case type_ref_tag : {
309
				    /* Reference initialiser */
310
				    e = init_assign ( t, cv_none, e, &err ) ;
311
				    break ;
312
				}
313
				case type_array_tag : {
314
				    /* Array initialiser */
315
				    if ( etag == exp_paren_tag ) {
316
					e = make_paren_exp ( e ) ;
317
				    }
318
				    e = init_array ( t, cv_none, e, 1, &err ) ;
319
				    break ;
320
				}
321
				case type_error_tag : {
322
				    e = convert_none ( e ) ;
323
				    break ;
324
				}
325
				default : {
326
				    /* Simple initialiser */
327
				    e = convert_lvalue ( e ) ;
328
				    e = init_assign ( t, cv_none, e, &err ) ;
329
				    break ;
330
				}
331
			    }
332
			}
333
		    }
334
		    force_tokdef-- ;
335
		    if ( !IS_NULL_err ( err ) ) {
336
			/* Conversion error */
337
			err = init_error ( err, 0 ) ;
338
			err = concat_error ( err, ERR_token_arg_exp ( id ) ) ;
339
			report ( crt_loc, err ) ;
340
		    }
341
		    if ( c == 1 && !is_const_exp ( e, 1 ) ) {
342
			report ( crt_loc, ERR_token_arg_const ( id ) ) ;
343
		    }
344
		    if ( !IS_NULL_exp ( d ) && !eq_exp ( e, d, 0 ) ) {
345
			int redef = 0 ;
346
			if ( ds & dspec_auto ) {
347
			    e = redef_exp ;
348
			} else {
349
			    if ( expl ) {
350
				if ( ds & dspec_main ) {
351
				    redef = 1 ;
352
				} else {
353
				    ds |= dspec_main ;
354
				}
355
			    } else {
356
				if ( ds & dspec_main ) {
357
				    e = d ;
358
				} else {
359
				    redef = 1 ;
360
				}
361
			    }
362
			}
363
			if ( redef ) {
364
			    PTR ( LOCATION ) loc = id_loc ( id ) ;
365
			    report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
366
			    ok = 0 ;
367
			}
368
		    } else {
369
			if ( expl && !( ds & dspec_auto ) ) {
370
			    /* Mark explicit definitions */
371
			    ds |= dspec_main ;
372
			}
373
		    }
374
		    COPY_exp ( tok_exp_value ( tok ), e ) ;
375
		    break ;
376
		}
377
 
378
		case tok_nat_tag :
379
		case tok_snat_tag : {
380
		    /* Constant tokens */
381
		    NAT n ;
382
		    ERROR err = NULL_err ;
383
		    e = convert_reference ( e, REF_NORMAL ) ;
384
		    e = convert_lvalue ( e ) ;
385
		    n = make_nat_exp ( e, &err ) ;
386
		    if ( !IS_NULL_err ( err ) ) {
387
			/* Not a constant expression */
388
			err = concat_error ( err, ERR_token_arg_nat ( id ) ) ;
389
			report ( crt_loc, err ) ;
390
		    } else {
391
			if ( tt == tok_nat_tag && is_negative_nat ( n ) ) {
392
			    /* Negative constant */
393
			    report ( crt_loc, ERR_token_arg_nat ( id ) ) ;
394
			    n = negate_nat ( n ) ;
395
			}
396
		    }
397
		    return ( define_nat_token ( id, n ) ) ;
398
		}
399
 
400
		case tok_stmt_tag : {
401
		    /* Statement tokens */
402
		    EXP d = DEREF_exp ( tok_stmt_value ( tok ) ) ;
403
		    if ( !IS_NULL_exp ( d ) && !eq_exp ( e, d, 0 ) ) {
404
			if ( ds & dspec_auto ) {
405
			    e = redef_exp ;
406
			} else {
407
			    PTR ( LOCATION ) loc = id_loc ( id ) ;
408
			    report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
409
			}
410
			ok = 0 ;
411
		    }
412
		    COPY_exp ( tok_stmt_value ( tok ), e ) ;
413
		    break ;
414
		}
415
 
416
		default : {
417
		    /* Other tokens */
418
		    return ( 0 ) ;
419
		}
420
	    }
421
	    if ( !( ds & dspec_auto ) ) no_token_defns++ ;
422
	    ds |= dspec_defn ;
423
	    COPY_dspec ( id_storage ( id ), ds ) ;
424
	    COPY_loc ( id_loc ( id ), crt_loc ) ;
425
	    return ( ok ) ;
426
	}
427
    }
428
    return ( 0 ) ;
429
}
430
 
431
 
432
/*
433
    DEFINE THE FIELDS OF A TYPE TOKEN
434
 
435
    This routine is called when a tokenised structure or union id is defined
436
    by the compound type t.  It checks for any tokenised members of id
437
    which may also be defined as a result of this identification.  This
438
    should really be done by the class merging routines.
439
*/
440
 
441
static void define_field_tokens
442
    PROTO_N ( ( id, t ) )
443
    PROTO_T ( IDENTIFIER id X TYPE t )
444
{
445
    IDENTIFIER tid = DEREF_id ( id_token_alt ( id ) ) ;
446
    unsigned tag = TAG_id ( tid ) ;
447
    if ( tag == id_class_name_tag || tag == id_class_alias_tag ) {
448
	TYPE s = DEREF_type ( id_class_name_etc_defn ( tid ) ) ;
449
	if ( IS_type_compound ( s ) && IS_type_compound ( t ) ) {
450
	    MEMBER mem ;
451
	    CLASS_TYPE cs = DEREF_ctype ( type_compound_defn ( s ) ) ;
452
	    CLASS_TYPE ct = DEREF_ctype ( type_compound_defn ( t ) ) ;
453
	    NAMESPACE ns = DEREF_nspace ( ctype_member ( cs ) ) ;
454
	    NAMESPACE nt = DEREF_nspace ( ctype_member ( ct ) ) ;
455
 
456
	    /* Check that keys match for type aliases */
457
	    if ( tag == id_class_alias_tag ) {
458
		BASE_TYPE bs = find_class_key ( cs ) ;
459
		BASE_TYPE bt = find_class_key ( ct ) ;
460
		if ( !equal_key ( bs, bt ) ) {
461
		    PTR ( LOCATION ) loc = id_loc ( id ) ;
462
		    ERROR err = ERR_dcl_type_elab_bad ( bt, bs, id, loc ) ;
463
		    report ( crt_loc, err ) ;
464
		}
465
	    }
466
 
467
	    /* Scan through members of ns */
468
	    mem = DEREF_member ( nspace_ctype_first ( ns ) ) ;
469
	    while ( !IS_NULL_member ( mem ) ) {
470
		IDENTIFIER mid = DEREF_id ( member_id ( mem ) ) ;
471
		if ( !IS_NULL_id ( mid ) && IS_id_member ( mid ) ) {
472
		    DECL_SPEC ds = DEREF_dspec ( id_storage ( mid ) ) ;
473
		    if ( ds & dspec_token ) {
474
			/* Tokenised member found */
475
			HASHID nm = DEREF_hashid ( id_name ( mid ) ) ;
476
			IDENTIFIER nid = search_field ( nt, nm, 0, 0 ) ;
477
			if ( !IS_NULL_id ( nid ) ) {
478
			    /* Token definition found */
479
			    IDENTIFIER tok = find_token ( mid ) ;
480
			    ds = DEREF_dspec ( id_storage ( tok ) ) ;
481
			    if ( ds & dspec_pure ) {
482
				LOCATION loc ;
483
				DEREF_loc ( id_loc ( nid ), loc ) ;
484
				report ( loc, ERR_token_def_not ( nid ) ) ;
485
			    } else {
486
				OFFSET off ;
487
				TYPE r = NULL_type ;
488
				off = offset_member ( t, nid, &r, nt, 0 ) ;
489
				IGNORE define_mem_token ( tok, off, r, 1 ) ;
490
			    }
491
			} else {
492
			    /* Copy tokenised member */
493
			    MEMBER mem2 = search_member ( nt, nm, 1 ) ;
494
			    mid = copy_id ( mid, 0 ) ;
495
			    COPY_nspace ( id_parent ( mid ), nt ) ;
496
			    set_member ( mem2, mid ) ;
497
			}
498
		    }
499
		}
500
		mem = DEREF_member ( member_next ( mem ) ) ;
501
	    }
502
 
503
	    /* Scan through members of nt */
504
	    mem = DEREF_member ( nspace_ctype_first ( nt ) ) ;
505
	    while ( !IS_NULL_member ( mem ) ) {
506
		MEMBER mem2 = NULL_member ;
507
		IDENTIFIER mid = DEREF_id ( member_id ( mem ) ) ;
508
		IDENTIFIER nid = DEREF_id ( member_alt ( mem ) ) ;
509
		if ( !IS_NULL_id ( mid ) ) {
510
		    IDENTIFIER pid ;
511
		    HASHID nm = DEREF_hashid ( id_name ( mid ) ) ;
512
		    mem2 = search_member ( ns, nm, 1 ) ;
513
		    mid = copy_id ( mid, 0 ) ;
514
		    COPY_nspace ( id_parent ( mid ), ns ) ;
515
		    pid = DEREF_id ( member_id ( mem2 ) ) ;
516
		    if ( IS_NULL_id ( pid ) ) {
517
			set_member ( mem2, mid ) ;
518
		    }
519
		}
520
		if ( !IS_NULL_id ( nid ) && !EQ_id ( mid, nid ) ) {
521
		    if ( IS_NULL_member ( mem2 ) ) {
522
			HASHID nm = DEREF_hashid ( id_name ( nid ) ) ;
523
			mem2 = search_member ( ns, nm, 1 ) ;
524
		    }
525
		    nid = copy_id ( nid, 0 ) ;
526
		    COPY_nspace ( id_parent ( nid ), ns ) ;
527
		    if ( !IS_NULL_id ( nid ) ) {
528
			set_type_member ( mem2, mid ) ;
529
		    }
530
		}
531
		mem = DEREF_member ( member_next ( mem ) ) ;
532
	    }
533
	}
534
    }
535
    return ;
536
}
537
 
538
 
539
/*
540
    CHECK A TYPE CATEGORY
541
 
542
    This routine checks whether the type t of category ca can be used to
543
    define a token of kind bt.
544
*/
545
 
546
static int match_type_token
547
    PROTO_N ( ( bt, ca, t ) )
548
    PROTO_T ( BASE_TYPE bt X unsigned ca X TYPE t )
549
{
550
    int ok = 1 ;
551
    if ( bt & btype_star ) {
552
	/* Scalar types */
553
	if ( !IS_TYPE_SCALAR ( ca ) ) ok = 0 ;
554
    } else if ( bt & btype_float ) {
555
	/* Arithmetic types */
556
	if ( bt & btype_int ) {
557
	    if ( !IS_TYPE_ARITH ( ca ) ) ok = 0 ;
558
	} else {
559
	    if ( !IS_TYPE_FLOAT ( ca ) ) ok = 0 ;
560
	}
561
    } else if ( bt & btype_int ) {
562
	/* Integral types */
563
	if ( IS_TYPE_INT ( ca ) ) {
564
	    if ( bt & btype_signed ) {
565
		if ( check_int_type ( t, btype_unsigned ) ) ok = 0 ;
566
	    } else if ( bt & btype_unsigned ) {
567
		if ( check_int_type ( t, btype_signed ) ) ok = 0 ;
568
	    }
569
	} else {
570
	    ok = 0 ;
571
	}
572
    }
573
    return ( ok ) ;
574
}
575
 
576
 
577
/*
578
    DEFINE A TYPE TOKEN
579
 
580
    This routine defines the type token id to be t.  It returns true if
581
    the token is assigned a value.  qual is as in check_compatible.
582
*/
583
 
584
int define_type_token
585
    PROTO_N ( ( id, t, qual ) )
586
    PROTO_T ( IDENTIFIER id X TYPE t X int qual )
587
{
588
    if ( !IS_NULL_type ( t ) ) {
589
	DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
590
	if ( !( ds & dspec_pure ) ) {
591
	    TYPE s ;
592
	    int ok = 1 ;
593
	    int check_promote = 0 ;
594
	    TOKEN tok = find_tokdef ( id ) ;
595
	    if ( IS_NULL_tok ( tok ) || !IS_tok_type ( tok ) ) return ( 0 ) ;
596
	    s = DEREF_type ( tok_type_value ( tok ) ) ;
597
	    if ( !IS_NULL_type ( s ) ) {
598
		ERROR err = NULL_err ;
599
		t = check_compatible ( s, t, qual, &err, 1 ) ;
600
		if ( !IS_NULL_err ( err ) ) {
601
		    if ( ds & dspec_auto ) {
602
			destroy_error ( err, 1 ) ;
603
			t = redef_type ;
604
		    } else {
605
			ERROR err2 ;
606
			err2 = ERR_token_redef ( id, id_loc ( id ) ) ;
607
			err = concat_error ( err, err2 ) ;
608
			report ( crt_loc, err ) ;
609
		    }
610
		    ok = 0 ;
611
		}
612
	    } else {
613
		unsigned ca = type_category ( &t ) ;
614
		BASE_TYPE bt = DEREF_btype ( tok_type_kind ( tok ) ) ;
615
		if ( !( bt & btype_template ) ) {
616
		    /* Tokens */
617
		    ERROR err = NULL_err ;
618
		    switch ( TAG_type ( t ) ) {
619
			case type_ref_tag :
620
			case type_func_tag :
621
			case type_bitfield_tag : {
622
			    /* These types can't be tokenised */
623
			    ok = 0 ;
624
			    break ;
625
			}
626
			case type_compound_tag : {
627
			    /* Can only tokenise trivial classes */
628
			    if ( bt != btype_none || !( ds & dspec_auto ) ) {
629
				CLASS_TYPE ct ;
630
				ct = DEREF_ctype ( type_compound_defn ( t ) ) ;
631
				err = check_trivial_class ( ct ) ;
632
				if ( !IS_NULL_err ( err ) ) ok = 0 ;
633
			    }
634
			    break ;
635
			}
636
		    }
637
		    if ( bt ) {
638
			if ( bt & btype_named ) {
639
			    /* Structure and union types */
640
			    if ( IS_type_compound ( t ) ) {
641
				if ( !( ds & dspec_auto ) ) {
642
				    /* Check structure fields */
643
				    define_field_tokens ( id, t ) ;
644
				}
645
			    } else {
646
				ok = 0 ;
647
			    }
648
			} else {
649
			    /* Check scalar types */
650
			    if ( !match_type_token ( bt, ca, t ) ) ok = 0 ;
651
			}
652
			if ( bt & btype_int ) check_promote = ok ;
653
		    }
654
		    if ( !ok ) {
655
			/* Report any type mismatch errors */
656
			if ( !IS_type_error ( t ) ) {
657
			    int lex = type_token_key ( bt ) ;
658
			    ERROR err2 = ERR_token_arg_type ( lex, id, t ) ;
659
			    err = concat_error ( err, err2 ) ;
660
			    report ( crt_loc, err ) ;
661
			    t = type_error ;
662
			}
663
		    }
664
		}
665
		if ( !IS_TYPE_INT ( ca ) ) check_promote = 0 ;
666
	    }
667
	    COPY_type ( tok_type_value ( tok ), t ) ;
668
	    if ( ds & dspec_auto ) {
669
		check_promote = 0 ;
670
	    } else {
671
		no_token_defns++ ;
672
	    }
673
	    ds |= dspec_defn ;
674
	    COPY_dspec ( id_storage ( id ), ds ) ;
675
	    COPY_loc ( id_loc ( id ), crt_loc ) ;
676
	    if ( check_promote ) {
677
		/* Check that promoted types are compatible */
678
		s = apply_itype_token ( id, NULL_list ( TOKEN ) ) ;
679
		t = promote_type ( t ) ;
680
		set_promote_type ( s, t, ntype_none ) ;
681
	    }
682
	    return ( ok ) ;
683
	}
684
    }
685
    return ( 0 ) ;
686
}
687
 
688
 
689
/*
690
    DEFINE A TEMPLATE TEMPLATE PARAMETER
691
 
692
    This routine defines the template template parameter id to be the
693
    class given by tid.  It returns true if the parameter is assigned a
694
    value.
695
*/
696
 
697
int define_templ_token
698
    PROTO_N ( ( id, tid ) )
699
    PROTO_T ( IDENTIFIER id X IDENTIFIER tid )
700
{
701
    if ( !IS_NULL_id ( tid ) ) {
702
	DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
703
	if ( !( ds & dspec_pure ) ) {
704
	    TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
705
	    if ( IS_tok_class ( tok ) ) {
706
		int ok = 0 ;
707
		IDENTIFIER sid = DEREF_id ( tok_class_value ( tok ) ) ;
708
		if ( EQ_id ( sid, tid ) ) return ( 1 ) ;
709
		if ( IS_id_class_name_etc ( tid ) ) {
710
		    TYPE t = DEREF_type ( tok_class_type ( tok ) ) ;
711
		    TYPE s = DEREF_type ( id_class_name_etc_defn ( tid ) ) ;
712
		    if ( IS_type_templ ( t ) && IS_type_templ ( s ) ) {
713
			/* Check for equality of template parameters */
714
			LIST ( IDENTIFIER ) ps, pt ;
715
			TOKEN as = DEREF_tok ( type_templ_sort ( s ) ) ;
716
			TOKEN at = DEREF_tok ( type_templ_sort ( t ) ) ;
717
			ps = DEREF_list ( tok_templ_pids ( as ) ) ;
718
			pt = DEREF_list ( tok_templ_pids ( at ) ) ;
719
			ok = eq_templ_params ( ps, pt ) ;
720
			restore_templ_params ( ps ) ;
721
		    }
722
		    if ( !ok ) {
723
			/* Report illegal definitions */
724
			ERROR err = ERR_temp_arg_templ_bad ( id, s ) ;
725
			report ( crt_loc, err ) ;
726
		    }
727
		    if ( !IS_NULL_id ( sid ) ) {
728
			/* Check for redefinitions */
729
			if ( ds & dspec_auto ) {
730
			    tid = redef_id ;
731
			} else {
732
			    PTR ( LOCATION ) loc = id_loc ( id ) ;
733
			    report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
734
			}
735
			ok = 0 ;
736
		    }
737
		} else {
738
		    ok = 0 ;
739
		}
740
		COPY_id ( tok_class_value ( tok ), tid ) ;
741
		if ( !( ds & dspec_auto ) ) no_token_defns++ ;
742
		ds |= dspec_defn ;
743
		COPY_dspec ( id_storage ( id ), ds ) ;
744
		COPY_loc ( id_loc ( id ), crt_loc ) ;
745
		return ( ok ) ;
746
	    }
747
	}
748
    }
749
    return ( 0 ) ;
750
}
751
 
752
 
753
/*
754
    DEFINE A MEMBER TOKEN
755
 
756
    This routine defines the member token id to be a member of offset off
757
    and type t.  It returns true if the token is assigned a value.  ext is
758
    true for an external token definition.
759
*/
760
 
761
int define_mem_token
762
    PROTO_N ( ( id, off, t, ext ) )
763
    PROTO_T ( IDENTIFIER id X OFFSET off X TYPE t X int ext )
764
{
765
    if ( !IS_NULL_off ( off ) ) {
766
	DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
767
	if ( ( ds & dspec_auto ) && ext ) {
768
	    ERROR err = ERR_class_mem_redecl ( id, id_loc ( id ) ) ;
769
	    report ( crt_loc, err ) ;
770
	} else if ( !( ds & dspec_pure ) ) {
771
	    TOKEN tok = find_tokdef ( id ) ;
772
	    if ( !IS_NULL_tok ( tok ) && IS_tok_member ( tok ) ) {
773
		TYPE u ;
774
		ERROR err = NULL_err ;
775
		TYPE s = DEREF_type ( tok_member_type ( tok ) ) ;
776
		OFFSET d = DEREF_off ( tok_member_value ( tok ) ) ;
777
		if ( !IS_NULL_off ( d ) && !eq_offset ( off, d, 0 ) ) {
778
		    if ( ds & dspec_auto ) {
779
			off = redef_off ;
780
		    } else {
781
			PTR ( LOCATION ) loc = id_loc ( id ) ;
782
			report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
783
		    }
784
		}
785
		u = check_compatible ( s, t, 0, &err, 0 ) ;
786
		if ( !IS_NULL_err ( err ) ) {
787
		    /* Member type is wrong */
788
		    if ( eq_type_offset ( s, t ) ) {
789
			/* Types have same representation */
790
			err = set_severity ( err, OPT_member_incompat, -1 ) ;
791
		    }
792
		    err = concat_error ( err, ERR_token_arg_mem ( id ) ) ;
793
		    report ( crt_loc, err ) ;
794
		}
795
		COPY_off ( tok_member_value ( tok ), off ) ;
796
		if ( !( ds & dspec_auto ) ) {
797
		    if ( IS_type_error ( s ) ) {
798
			/* Fill in type if not known */
799
			IDENTIFIER mid = DEREF_id ( id_token_alt ( id ) ) ;
800
			COPY_type ( tok_member_type ( tok ), u ) ;
801
			u = lvalue_type ( u ) ;
802
			COPY_type ( id_member_type ( mid ), u ) ;
803
		    }
804
		    no_token_defns++ ;
805
		}
806
		ds |= dspec_defn ;
807
		COPY_dspec ( id_storage ( id ), ds ) ;
808
		COPY_loc ( id_loc ( id ), crt_loc ) ;
809
		UNUSED ( ext ) ;
810
		return ( 1 ) ;
811
	    }
812
	}
813
    }
814
    return ( 0 ) ;
815
}
816
 
817
 
818
/*
819
    DEFINE A FUNCTION TOKEN
820
 
821
    This routine defines the function token id to be the function fid.
822
*/
823
 
824
int define_func_token
825
    PROTO_N ( ( id, fid ) )
826
    PROTO_T ( IDENTIFIER id X IDENTIFIER fid )
827
{
828
    if ( !IS_NULL_id ( fid ) ) {
829
	DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
830
	if ( !( ds & dspec_pure ) ) {
831
	    TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
832
	    if ( IS_tok_func ( tok ) ) {
833
		int eq = 0 ;
834
		int redef = 0 ;
835
		LIST ( IDENTIFIER ) pids = NULL_list ( IDENTIFIER ) ;
836
		TYPE t = DEREF_type ( tok_func_type ( tok ) ) ;
837
		TOKEN res = DEREF_tok ( tok_func_proc ( tok ) ) ;
838
		IDENTIFIER pid = DEREF_id ( tok_func_defn ( tok ) ) ;
839
		IDENTIFIER qid = resolve_func ( fid, t, 1, 0, pids, &eq ) ;
840
		if ( !IS_NULL_id ( qid ) ) {
841
		    switch ( TAG_id ( qid ) ) {
842
			case id_function_tag :
843
			case id_stat_mem_func_tag : {
844
			    use_id ( qid, 0 ) ;
845
			    break ;
846
			}
847
			default : {
848
			    qid = NULL_id ;
849
			    break ;
850
			}
851
		    }
852
		}
853
		if ( IS_NULL_id ( qid ) ) {
854
		    report ( crt_loc, ERR_token_def_func ( fid, t ) ) ;
855
		    qid = fid ;
856
		} else {
857
		    TYPE s = DEREF_type ( id_function_etc_type ( qid ) ) ;
858
		    if ( eq == 2 ) {
859
			report ( crt_loc, ERR_dcl_link_conv () ) ;
860
		    }
861
		    if ( eq_except ( s, t ) != 2 ) {
862
			report ( crt_loc, ERR_token_def_except () ) ;
863
		    }
864
		}
865
		if ( !IS_NULL_tok ( res ) ) {
866
		    /* Previously defined by macro */
867
		    redef = 1 ;
868
		}
869
		if ( !IS_NULL_id ( pid ) && !EQ_id ( pid, qid ) ) {
870
		    /* Previously defined by different function */
871
		    redef = 1 ;
872
		}
873
		if ( redef ) {
874
		    PTR ( LOCATION ) loc = id_loc ( id ) ;
875
		    report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
876
		}
877
		COPY_id ( tok_func_defn ( tok ), qid ) ;
878
		if ( !( ds & dspec_auto ) ) no_token_defns++ ;
879
		ds |= dspec_defn ;
880
		COPY_dspec ( id_storage ( id ), ds ) ;
881
		COPY_loc ( id_loc ( id ), crt_loc ) ;
882
		return ( 1 ) ;
883
	    }
884
	}
885
    }
886
    return ( 0 ) ;
887
}
888
 
889
 
890
/*
891
    PROCEDURE TOKEN FLAG
892
 
893
    This variable is used to keep track of the depth of procedure token
894
    arguments being read.
895
*/
896
 
897
int in_proc_token = 0 ;
898
 
899
 
900
/*
901
    FIND A TOKEN MEMBER TYPE
902
 
903
    If id represents a member token then this routine returns the type
904
    of which id is a member, suitably expanded.  Otherwise the null type
905
    is returned.  This represents the only barrier to doing argument
906
    deduction in procedure tokens independently for each argument - if
907
    a member parameter is a member of a previous structure parameter
908
    (as in offsetof), we need to know the value of the structure
909
    argument before we can decode the member argument.
910
*/
911
 
912
static TYPE expand_member_type
913
    PROTO_N ( ( id ) )
914
    PROTO_T ( IDENTIFIER id )
915
{
916
    TYPE t = NULL_type ;
917
    TOKEN tok = find_tokdef ( id ) ;
918
    if ( !IS_NULL_tok ( tok ) && IS_tok_member ( tok ) ) {
919
	t = DEREF_type ( tok_member_of ( tok ) ) ;
920
	t = expand_type ( t, 1 ) ;
921
    }
922
    return ( t ) ;
923
}
924
 
925
 
926
/*
927
    PARSE A TOKEN DEFINITION
928
 
929
    This routine reads the definition of the token id.  It returns true
930
    if a value is assigned to the token.  If mt is not null it is the
931
    class type for a member token.  fn is true for procedure tokens and
932
    mac is true is true for macro token definitions.
933
*/
934
 
935
static int parse_token
936
    PROTO_N ( ( id, t, fn, mac, pids ) )
937
    PROTO_T ( IDENTIFIER id X TYPE t X int fn X int mac X
938
	      LIST ( IDENTIFIER ) pids )
939
{
940
    int def ;
941
    TOKEN tok = NULL_tok ;
942
    unsigned tag = null_tag ;
943
    if ( IS_id_token ( id ) ) {
944
	/* Find token sort */
945
	tok = DEREF_tok ( id_token_sort ( id ) ) ;
946
	if ( fn ) tok = find_tokdef ( id ) ;
947
	tag = TAG_tok ( tok ) ;
948
    }
949
    switch ( tag ) {
950
 
951
	case tok_exp_tag :
952
	case tok_nat_tag :
953
	case tok_snat_tag : {
954
	    /* Expression tokens */
955
	    EXP e = NULL_exp ;
956
	    ERROR err = NULL_err ;
957
	    int tn = crt_lex_token ;
958
	    if ( mac && tn == lex_newline && tag == tok_exp_tag ) {
959
		/* Map empty definition to default value */
960
		TYPE s = DEREF_type ( tok_exp_type ( tok ) ) ;
961
		e = init_empty ( s, cv_none, 1, &err ) ;
962
	    } else if ( mac && tn == lex_open_Hbrace_H1 ) {
963
		parse_init ( id, &e ) ;
964
	    } else {
965
		parse_exp ( &e ) ;
966
	    }
967
	    if ( !IS_NULL_exp ( e ) && tag == tok_exp_tag ) {
968
		/* Deal with overloaded functions */
969
		TYPE s = DEREF_type ( tok_exp_type ( tok ) ) ;
970
		force_tokdef++ ;
971
		e = resolve_cast ( s, e, &err, 1, 0, pids ) ;
972
		if ( !IS_NULL_err ( err ) ) {
973
		    err = concat_error ( err, ERR_token_arg_exp ( id ) ) ;
974
		    report ( crt_loc, err ) ;
975
		}
976
		force_tokdef-- ;
977
	    }
978
	    def = define_exp_token ( id, e, 1 ) ;
979
	    break ;
980
	}
981
 
982
	case tok_stmt_tag : {
983
	    /* Statement tokens */
984
	    EXP e ;
985
	    EXP a = NULL_exp ;
986
	    int ic = in_class_defn ;
987
	    int fd = in_function_defn ;
988
	    int uc = unreached_code ;
989
	    TYPE r = crt_func_return ;
990
	    NAMESPACE bns = block_namespace ;
991
	    DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
992
	    IDENTIFIER fid = DEREF_id ( id_token_alt ( id ) ) ;
993
	    unreached_code = 0 ;
994
	    if ( fd ) {
995
		if ( !( ds & dspec_auto ) ) {
996
		    /* Force return errors */
997
		    crt_func_return = NULL_type ;
998
		}
999
	    } else {
1000
		/* Treat as dummy function definition */
1001
		in_class_defn = 0 ;
1002
		in_function_defn = fd + 1 ;
1003
		really_in_function_defn++ ;
1004
		begin_function ( fid ) ;
1005
		crt_func_return = NULL_type ;
1006
	    }
1007
	    block_namespace = NULL_nspace ;
1008
	    e = begin_compound_stmt ( 1 ) ;
1009
	    parse_stmt ( &a ) ;
1010
	    e = add_compound_stmt ( e, a ) ;
1011
	    e = end_compound_stmt ( e ) ;
1012
	    if ( fd ) {
1013
		if ( ds & dspec_auto ) {
1014
		    /* Set dummy parent statement */
1015
		    MAKE_exp_token ( type_void, id, NULL_list ( TOKEN ), a ) ;
1016
		    set_parent_stmt ( e, a ) ;
1017
		}
1018
	    } else {
1019
		/* End dummy function definition */
1020
		if ( crt_access_list.pending ) {
1021
		    IGNORE report_access ( fid ) ;
1022
		}
1023
		e = end_function ( fid, e ) ;
1024
		really_in_function_defn-- ;
1025
		in_function_defn = fd ;
1026
		in_class_defn = ic ;
1027
	    }
1028
	    unreached_code = uc ;
1029
	    block_namespace = bns ;
1030
	    crt_func_return = r ;
1031
	    def = define_exp_token ( id, e, 1 ) ;
1032
	    break ;
1033
	}
1034
 
1035
	case tok_member_tag : {
1036
	    /* Member tokens */
1037
	    TYPE s = type_error ;
1038
	    OFFSET off = NULL_off ;
1039
	    if ( IS_NULL_type ( t ) ) t = expand_member_type ( id ) ;
1040
	    parse_offset ( NULL_off, t, &off, &s ) ;
1041
	    def = define_mem_token ( id, off, s, 0 ) ;
1042
	    break ;
1043
	}
1044
 
1045
	case tok_func_tag : {
1046
	    /* Function tokens */
1047
	    IDENTIFIER fid = NULL_id ;
1048
	    parse_id ( &fid ) ;
1049
	    def = define_func_token ( id, fid ) ;
1050
	    break ;
1051
	}
1052
 
1053
	default : {
1054
	    /* Type tokens */
1055
	    TYPE s = NULL_type ;
1056
	    have_type_specifier = 0 ;
1057
	    parse_type ( &s ) ;
1058
	    if ( tag == tok_type_tag ) {
1059
		/* Simple type token */
1060
		def = define_type_token ( id, s, 0 ) ;
1061
	    } else {
1062
		/* Complex type value */
1063
		TYPE r = DEREF_type ( id_class_name_etc_defn ( id ) ) ;
1064
		force_tokdef++ ;
1065
		def = eq_type ( r, s ) ;
1066
		if ( !def && !IS_NULL_type ( s ) ) {
1067
		    ERROR err = ERR_token_arg_type ( lex_type_Hcap, id, s ) ;
1068
		    report ( crt_loc, err ) ;
1069
		}
1070
		force_tokdef-- ;
1071
	    }
1072
	    break ;
1073
	}
1074
    }
1075
    return ( def ) ;
1076
}
1077
 
1078
 
1079
/*
1080
    SET A TOKEN VALUE
1081
 
1082
    This routine sets the value of the token id to be arg.
1083
*/
1084
 
1085
void assign_token
1086
    PROTO_N ( ( id, arg ) )
1087
    PROTO_T ( IDENTIFIER id X TOKEN arg )
1088
{
1089
    if ( !IS_NULL_tok ( arg ) ) {
1090
	TOKEN sort = DEREF_tok ( id_token_sort ( id ) ) ;
1091
	unsigned na = TAG_tok ( arg ) ;
1092
	unsigned nb = TAG_tok ( sort ) ;
1093
	if ( nb == tok_proc_tag ) {
1094
	    sort = DEREF_tok ( tok_proc_res ( sort ) ) ;
1095
	    nb = TAG_tok ( sort ) ;
1096
	}
1097
	if ( na == nb ) {
1098
	    switch ( na ) {
1099
		case tok_exp_tag : {
1100
		    EXP e = DEREF_exp ( tok_exp_value ( arg ) ) ;
1101
		    COPY_exp ( tok_exp_value ( sort ), e ) ;
1102
		    break ;
1103
		}
1104
		case tok_nat_tag :
1105
		case tok_snat_tag : {
1106
		    NAT n = DEREF_nat ( tok_nat_etc_value ( arg ) ) ;
1107
		    COPY_nat ( tok_nat_etc_value ( sort ), n ) ;
1108
		    break ;
1109
		}
1110
		case tok_stmt_tag : {
1111
		    EXP e = DEREF_exp ( tok_stmt_value ( arg ) ) ;
1112
		    COPY_exp ( tok_stmt_value ( sort ), e ) ;
1113
		    break ;
1114
		}
1115
		case tok_member_tag : {
1116
		    OFFSET off = DEREF_off ( tok_member_value ( arg ) ) ;
1117
		    COPY_off ( tok_member_value ( sort ), off ) ;
1118
		    break ;
1119
		}
1120
		case tok_type_tag : {
1121
		    TYPE t = DEREF_type ( tok_type_value ( arg ) ) ;
1122
		    COPY_type ( tok_type_value ( sort ), t ) ;
1123
		    break ;
1124
		}
1125
		case tok_class_tag : {
1126
		    IDENTIFIER cid = DEREF_id ( tok_class_value ( arg ) ) ;
1127
		    COPY_id ( tok_class_value ( sort ), cid ) ;
1128
		    break ;
1129
		}
1130
	    }
1131
	}
1132
    }
1133
    return ;
1134
}
1135
 
1136
 
1137
/*
1138
    TOKEN ARGUMENT STACKS
1139
 
1140
    These stacks are used to store the values of the token arguments to
1141
    allow for recursive token applications.
1142
*/
1143
 
1144
static STACK ( EXP ) token_exp_stack = NULL_stack ( EXP ) ;
1145
static STACK ( NAT ) token_nat_stack = NULL_stack ( NAT ) ;
1146
static STACK ( EXP ) token_stmt_stack = NULL_stack ( EXP ) ;
1147
static STACK ( OFFSET ) token_mem_stack = NULL_stack ( OFFSET ) ;
1148
static STACK ( TYPE ) token_type_stack = NULL_stack ( TYPE ) ;
1149
static STACK ( IDENTIFIER ) token_class_stack = NULL_stack ( IDENTIFIER ) ;
1150
 
1151
 
1152
/*
1153
    SAVE TOKEN ARGUMENT VALUES
1154
 
1155
    This routine saves the argument values for the token parameters pids
1156
    by pushing them onto the stacks above.  The argument values set to those
1157
    stored in args, or the null value when these are exhausted.  The routine
1158
    also clears the pure field of the token, returning 0 if they were
1159
    previously set.
1160
*/
1161
 
1162
int save_token_args
1163
    PROTO_N ( ( pids, args ) )
1164
    PROTO_T ( LIST ( IDENTIFIER ) pids X LIST ( TOKEN ) args )
1165
{
1166
    int depth = 1 ;
1167
    LIST ( IDENTIFIER ) bids = pids ;
1168
    while ( !IS_NULL_list ( bids ) ) {
1169
	IDENTIFIER bid = DEREF_id ( HEAD_list ( bids ) ) ;
1170
 
1171
	/* Get argument token value */
1172
	TOKEN atok = NULL_tok ;
1173
	unsigned at = null_tag ;
1174
	if ( !IS_NULL_list ( args ) ) {
1175
	    atok = DEREF_tok ( HEAD_list ( args ) ) ;
1176
	    if ( !IS_NULL_tok ( atok ) ) at = TAG_tok ( atok ) ;
1177
	    args = TAIL_list ( args ) ;
1178
	}
1179
 
1180
	/* Save previous token value */
1181
	if ( !IS_NULL_id ( bid ) && IS_id_token ( bid ) ) {
1182
	    DECL_SPEC ds ;
1183
	    TOKEN btok = DEREF_tok ( id_token_sort ( bid ) ) ;
1184
	    unsigned bt = TAG_tok ( btok ) ;
1185
	    switch ( bt ) {
1186
		case tok_exp_tag : {
1187
		    EXP e = DEREF_exp ( tok_exp_value ( btok ) ) ;
1188
		    PUSH_exp ( e, token_exp_stack ) ;
1189
		    if ( at == bt ) {
1190
			e = DEREF_exp ( tok_exp_value ( atok ) ) ;
1191
		    } else {
1192
			e = NULL_exp ;
1193
		    }
1194
		    COPY_exp ( tok_exp_value ( btok ), e ) ;
1195
		    break ;
1196
		}
1197
		case tok_nat_tag :
1198
		case tok_snat_tag : {
1199
		    NAT n = DEREF_nat ( tok_nat_etc_value ( btok ) ) ;
1200
		    PUSH_nat ( n, token_nat_stack ) ;
1201
		    if ( at == bt ) {
1202
			n = DEREF_nat ( tok_nat_etc_value ( atok ) ) ;
1203
		    } else {
1204
			n = NULL_nat ;
1205
		    }
1206
		    COPY_nat ( tok_nat_etc_value ( btok ), n ) ;
1207
		    break ;
1208
		}
1209
		case tok_stmt_tag : {
1210
		    EXP e = DEREF_exp ( tok_stmt_value ( btok ) ) ;
1211
		    PUSH_exp ( e, token_stmt_stack ) ;
1212
		    if ( at == bt ) {
1213
			e = DEREF_exp ( tok_stmt_value ( atok ) ) ;
1214
		    } else {
1215
			e = NULL_exp ;
1216
		    }
1217
		    COPY_exp ( tok_stmt_value ( btok ), e ) ;
1218
		    break ;
1219
		}
1220
		case tok_member_tag : {
1221
		    OFFSET off = DEREF_off ( tok_member_value ( btok ) ) ;
1222
		    PUSH_off ( off, token_mem_stack ) ;
1223
		    if ( at == bt ) {
1224
			off = DEREF_off ( tok_member_value ( atok ) ) ;
1225
		    } else {
1226
			off = NULL_off ;
1227
		    }
1228
		    COPY_off ( tok_member_value ( btok ), off ) ;
1229
		    break ;
1230
		}
1231
		case tok_type_tag : {
1232
		    TYPE t = DEREF_type ( tok_type_value ( btok ) ) ;
1233
		    PUSH_type ( t, token_type_stack ) ;
1234
		    if ( at == bt ) {
1235
			t = DEREF_type ( tok_type_value ( atok ) ) ;
1236
		    } else {
1237
			t = NULL_type ;
1238
		    }
1239
		    COPY_type ( tok_type_value ( btok ), t ) ;
1240
		    break ;
1241
		}
1242
		case tok_class_tag : {
1243
		    IDENTIFIER cid = DEREF_id ( tok_class_value ( btok ) ) ;
1244
		    PUSH_id ( cid, token_class_stack ) ;
1245
		    if ( at == bt ) {
1246
			cid = DEREF_id ( tok_class_value ( atok ) ) ;
1247
		    } else {
1248
			cid = NULL_id ;
1249
		    }
1250
		    COPY_id ( tok_class_value ( btok ), cid ) ;
1251
		    break ;
1252
		}
1253
		default : {
1254
		    /* Procedure arguments not allowed */
1255
		    break ;
1256
		}
1257
	    }
1258
 
1259
	    /* Allow definition of parameter */
1260
	    ds = DEREF_dspec ( id_storage ( bid ) ) ;
1261
	    if ( ds & dspec_pure ) {
1262
		ds &= ~dspec_pure ;
1263
		COPY_dspec ( id_storage ( bid ), ds ) ;
1264
		depth = 0 ;
1265
	    }
1266
	}
1267
	bids = TAIL_list ( bids ) ;
1268
    }
1269
    in_proc_token++ ;
1270
    return ( depth ) ;
1271
}
1272
 
1273
 
1274
/*
1275
    RESTORE TOKEN ARGUMENT VALUES
1276
 
1277
    This routine restores the argument values for the token parameters
1278
    pids by popping them from the stacks above.  The pure field of the
1279
    tokens is set if depth is 0.
1280
*/
1281
 
1282
void restore_token_args
1283
    PROTO_N ( ( pids, depth ) )
1284
    PROTO_T ( LIST ( IDENTIFIER ) pids X int depth )
1285
{
1286
    LIST ( IDENTIFIER ) bids = pids ;
1287
    if ( !IS_NULL_list ( bids ) ) {
1288
	IDENTIFIER bid = DEREF_id ( HEAD_list ( bids ) ) ;
1289
	bids = TAIL_list ( bids ) ;
1290
	if ( !IS_NULL_list ( bids ) ) {
1291
	    restore_token_args ( bids, depth ) ;
1292
	    in_proc_token++ ;
1293
	}
1294
	if ( !IS_NULL_id ( bid ) && IS_id_token ( bid ) ) {
1295
	    TOKEN btok = DEREF_tok ( id_token_sort ( bid ) ) ;
1296
	    unsigned bt = TAG_tok ( btok ) ;
1297
	    switch ( bt ) {
1298
		case tok_exp_tag : {
1299
		    EXP e ;
1300
		    POP_exp ( e, token_exp_stack ) ;
1301
		    COPY_exp ( tok_exp_value ( btok ), e ) ;
1302
		    break ;
1303
		}
1304
		case tok_nat_tag :
1305
		case tok_snat_tag : {
1306
		    NAT n ;
1307
		    POP_nat ( n, token_nat_stack ) ;
1308
		    COPY_nat ( tok_nat_etc_value ( btok ), n ) ;
1309
		    break ;
1310
		}
1311
		case tok_stmt_tag : {
1312
		    EXP e ;
1313
		    POP_exp ( e, token_stmt_stack ) ;
1314
		    COPY_exp ( tok_stmt_value ( btok ), e ) ;
1315
		    break ;
1316
		}
1317
		case tok_member_tag : {
1318
		    OFFSET off ;
1319
		    POP_off ( off, token_mem_stack ) ;
1320
		    COPY_off ( tok_member_value ( btok ), off ) ;
1321
		    break ;
1322
		}
1323
		case tok_type_tag : {
1324
		    TYPE t ;
1325
		    POP_type ( t, token_type_stack ) ;
1326
		    COPY_type ( tok_type_value ( btok ), t ) ;
1327
		    break ;
1328
		}
1329
		case tok_class_tag : {
1330
		    IDENTIFIER cid ;
1331
		    POP_id ( cid, token_class_stack ) ;
1332
		    COPY_id ( tok_class_value ( btok ), cid ) ;
1333
		    break ;
1334
		}
1335
		default : {
1336
		    /* Procedure arguments not allowed */
1337
		    break ;
1338
		}
1339
	    }
1340
	    if ( depth == 0 ) {
1341
		/* Can't define parameter at outer level */
1342
		DECL_SPEC ds = DEREF_dspec ( id_storage ( bid ) ) ;
1343
		ds |= dspec_pure ;
1344
		COPY_dspec ( id_storage ( bid ), ds ) ;
1345
	    }
1346
	}
1347
    }
1348
    in_proc_token-- ;
1349
    return ;
1350
}
1351
 
1352
 
1353
/*
1354
    MERGE TOKEN ARGUMENT VALUES
1355
 
1356
    This routine merges the argument values for the token parameters
1357
    pids with the values popped off the stacks above.  It returns true
1358
    if the merge was successful.  The pure field of the tokens is set
1359
    if depth is 0.
1360
*/
1361
 
1362
int merge_token_args
1363
    PROTO_N ( ( pids, depth, qual ) )
1364
    PROTO_T ( LIST ( IDENTIFIER ) pids X int depth X int qual )
1365
{
1366
    int ok = 1 ;
1367
    LIST ( IDENTIFIER ) bids = pids ;
1368
    if ( !IS_NULL_list ( bids ) ) {
1369
	IDENTIFIER bid = DEREF_id ( HEAD_list ( bids ) ) ;
1370
	bids = TAIL_list ( bids ) ;
1371
	if ( !IS_NULL_list ( bids ) ) {
1372
	    ok = merge_token_args ( bids, depth, qual ) ;
1373
	    in_proc_token++ ;
1374
	}
1375
	if ( !IS_NULL_id ( bid ) && IS_id_token ( bid ) ) {
1376
	    TOKEN btok = DEREF_tok ( id_token_sort ( bid ) ) ;
1377
	    unsigned bt = TAG_tok ( btok ) ;
1378
	    switch ( bt ) {
1379
		case tok_exp_tag : {
1380
		    EXP e ;
1381
		    POP_exp ( e, token_exp_stack ) ;
1382
		    if ( !IS_NULL_exp ( e ) ) {
1383
			if ( !define_exp_token ( bid, e, 1 ) ) ok = 0 ;
1384
		    }
1385
		    break ;
1386
		}
1387
		case tok_nat_tag :
1388
		case tok_snat_tag : {
1389
		    NAT n ;
1390
		    POP_nat ( n, token_nat_stack ) ;
1391
		    if ( !IS_NULL_nat ( n ) ) {
1392
			if ( !define_nat_token ( bid, n ) ) ok = 0 ;
1393
		    }
1394
		    break ;
1395
		}
1396
		case tok_stmt_tag : {
1397
		    EXP e ;
1398
		    POP_exp ( e, token_stmt_stack ) ;
1399
		    if ( !IS_NULL_exp ( e ) ) {
1400
			if ( !define_exp_token ( bid, e, 1 ) ) ok = 0 ;
1401
		    }
1402
		    break ;
1403
		}
1404
		case tok_member_tag : {
1405
		    OFFSET off ;
1406
		    POP_off ( off, token_mem_stack ) ;
1407
		    if ( !IS_NULL_off ( off ) ) {
1408
			TYPE t = DEREF_type ( tok_member_type ( btok ) ) ;
1409
			if ( !define_mem_token ( bid, off, t, 0 ) ) ok = 0 ;
1410
		    }
1411
		    break ;
1412
		}
1413
		case tok_type_tag : {
1414
		    TYPE t ;
1415
		    POP_type ( t, token_type_stack ) ;
1416
		    if ( !IS_NULL_type ( t ) ) {
1417
			if ( !define_type_token ( bid, t, qual ) ) ok = 0 ;
1418
		    }
1419
		    break ;
1420
		}
1421
		case tok_class_tag : {
1422
		    IDENTIFIER cid ;
1423
		    POP_id ( cid, token_class_stack ) ;
1424
		    if ( !IS_NULL_id ( cid ) ) {
1425
			if ( !define_templ_token ( bid, cid ) ) ok = 0 ;
1426
		    }
1427
		    break ;
1428
		}
1429
		default : {
1430
		    /* Procedure arguments not allowed */
1431
		    break ;
1432
		}
1433
	    }
1434
	    if ( depth == 0 ) {
1435
		/* Can't define parameter at outer level */
1436
		DECL_SPEC ds = DEREF_dspec ( id_storage ( bid ) ) ;
1437
		ds |= dspec_pure ;
1438
		COPY_dspec ( id_storage ( bid ), ds ) ;
1439
	    }
1440
	}
1441
    }
1442
    in_proc_token-- ;
1443
    return ( ok ) ;
1444
}
1445
 
1446
 
1447
/*
1448
    HAS A TOKEN BEEN BOUND?
1449
 
1450
    This routine checks whether a value has been bound to the token tok.
1451
    If def is true then a dummy value is constructed for unbound values.
1452
*/
1453
 
1454
int is_bound_tok
1455
    PROTO_N ( ( tok, def ) )
1456
    PROTO_T ( TOKEN tok X int def )
1457
{
1458
    int bound = 1 ;
1459
    if ( !IS_NULL_tok ( tok ) ) {
1460
	switch ( TAG_tok ( tok ) ) {
1461
	    case tok_exp_tag : {
1462
		/* Expression tokens */
1463
		EXP e = DEREF_exp ( tok_exp_value ( tok ) ) ;
1464
		if ( IS_NULL_exp ( e ) || EQ_exp ( e, redef_exp ) ) {
1465
		    if ( def ) {
1466
			TYPE t = DEREF_type ( tok_exp_type ( tok ) ) ;
1467
			MAKE_exp_value ( t, e ) ;
1468
			COPY_exp ( tok_exp_value ( tok ), e ) ;
1469
		    }
1470
		    bound = 0 ;
1471
		}
1472
		break ;
1473
	    }
1474
	    case tok_nat_tag :
1475
	    case tok_snat_tag : {
1476
		/* Integer constant tokens */
1477
		NAT n = DEREF_nat ( tok_nat_etc_value ( tok ) ) ;
1478
		if ( IS_NULL_nat ( n ) || EQ_nat ( n, redef_nat ) ) {
1479
		    if ( def ) {
1480
			n = small_nat [1] ;
1481
			COPY_nat ( tok_nat_etc_value ( tok ), n ) ;
1482
		    }
1483
		    bound = 0 ;
1484
		}
1485
		break ;
1486
	    }
1487
	    case tok_stmt_tag : {
1488
		/* Statement tokens */
1489
		EXP e = DEREF_exp ( tok_stmt_value ( tok ) ) ;
1490
		if ( IS_NULL_exp ( e ) || EQ_exp ( e, redef_exp ) ) {
1491
		    if ( def ) {
1492
			MAKE_exp_value ( type_void, e ) ;
1493
			COPY_exp ( tok_stmt_value ( tok ), e ) ;
1494
		    }
1495
		    bound = 0 ;
1496
		}
1497
		break ;
1498
	    }
1499
	    case tok_member_tag : {
1500
		/* Member tokens */
1501
		OFFSET off = DEREF_off ( tok_member_value ( tok ) ) ;
1502
		if ( IS_NULL_off ( off ) || EQ_off ( off, redef_off ) ) {
1503
		    if ( def ) {
1504
			TYPE t = DEREF_type ( tok_member_type ( tok ) ) ;
1505
			MAKE_off_zero ( t, off ) ;
1506
			COPY_off ( tok_member_value ( tok ), off ) ;
1507
		    }
1508
		    bound = 0 ;
1509
		}
1510
		break ;
1511
	    }
1512
	    case tok_type_tag : {
1513
		/* Type tokens */
1514
		TYPE t = DEREF_type ( tok_type_value ( tok ) ) ;
1515
		if ( IS_NULL_type ( t ) || EQ_type ( t, redef_type ) ) {
1516
		    if ( def ) {
1517
			t = type_error ;
1518
			COPY_type ( tok_type_value ( tok ), t ) ;
1519
		    }
1520
		    bound = 0 ;
1521
		}
1522
		break ;
1523
	    }
1524
	    case tok_class_tag : {
1525
		/* Template class tokens */
1526
		IDENTIFIER cid = DEREF_id ( tok_class_value ( tok ) ) ;
1527
		if ( IS_NULL_id ( cid ) || EQ_id ( cid, redef_id ) ) {
1528
		    if ( def ) {
1529
			HASHID nm = KEYWORD ( lex_zzzz ) ;
1530
			cid = DEREF_id ( hashid_id ( nm ) ) ;
1531
			COPY_id ( tok_class_value ( tok ), cid ) ;
1532
		    }
1533
		    bound = 0 ;
1534
		}
1535
		break ;
1536
	    }
1537
	}
1538
    }
1539
    return ( bound ) ;
1540
}
1541
 
1542
 
1543
/*
1544
    CONSTRUCT A LIST OF TOKEN ARGUMENTS
1545
 
1546
    This routine constructs a list of token arguments for the token id
1547
    from the token parameters pids.  Any errors arising from undefined
1548
    parameters are added to err.
1549
*/
1550
 
1551
LIST ( TOKEN ) make_token_args
1552
    PROTO_N ( ( id, pids, err ) )
1553
    PROTO_T ( IDENTIFIER id X LIST ( IDENTIFIER ) pids X ERROR *err )
1554
{
1555
    LIST ( TOKEN ) args = NULL_list ( TOKEN ) ;
1556
    while ( !IS_NULL_list ( pids ) ) {
1557
	IDENTIFIER pid = DEREF_id ( HEAD_list ( pids ) ) ;
1558
	if ( !IS_NULL_id ( pid ) && IS_id_token ( pid ) ) {
1559
	    TOKEN tok = DEREF_tok ( id_token_sort ( pid ) ) ;
1560
	    if ( !is_bound_tok ( tok, 1 ) ) {
1561
		/* Token parameter not defined */
1562
		if ( IS_id_token ( id ) ) {
1563
		    add_error ( err, ERR_token_arg_undef ( pid, id ) ) ;
1564
		} else {
1565
		    add_error ( err, ERR_temp_deduct_undef ( pid, id ) ) ;
1566
		}
1567
	    }
1568
	    tok = expand_sort ( tok, 2, 1 ) ;
1569
	    CONS_tok ( tok, args, args ) ;
1570
	}
1571
	pids = TAIL_list ( pids ) ;
1572
    }
1573
    args = REVERSE_list ( args ) ;
1574
    return ( args ) ;
1575
}
1576
 
1577
 
1578
/*
1579
    SKIP TOKEN ARGUMENTS
1580
 
1581
    This routine skips a set of token arguments for the token id.  It is
1582
    entered with the current token pointing to the token name preceding
1583
    the initial open bracket.
1584
*/
1585
 
1586
PPTOKEN *skip_token_args
1587
    PROTO_N ( ( id ) )
1588
    PROTO_T ( IDENTIFIER id )
1589
{
1590
    PPTOKEN *q ;
1591
    LOCATION loc ;
1592
    int brackets = 0 ;
1593
    PPTOKEN *p = crt_token ;
1594
    loc = crt_loc ;
1595
    for ( ; ; ) {
1596
	int t = expand_preproc ( EXPAND_AHEAD ) ;
1597
	if ( t == lex_open_Hround ) {
1598
	    brackets++ ;
1599
	} else if ( t == lex_close_Hround ) {
1600
	    if ( --brackets == 0 ) break ;
1601
	} else if ( t == lex_eof ) {
1602
	    HASHID nm = DEREF_hashid ( id_name ( id ) ) ;
1603
	    report ( loc, ERR_cpp_replace_arg_eof ( nm ) ) ;
1604
	    break ;
1605
	}
1606
    }
1607
    q = p->next ;
1608
    snip_tokens ( q, crt_token ) ;
1609
    crt_token = p ;
1610
    return ( q ) ;
1611
}
1612
 
1613
 
1614
/*
1615
    PARSE A SET OF TOKEN ARGUMENTS
1616
 
1617
    This routine parses the preprocessing tokens p as a list of arguments
1618
    for the procedure token id.
1619
*/
1620
 
1621
static LIST ( TOKEN ) parse_token_args
1622
    PROTO_N ( ( id, p ) )
1623
    PROTO_T ( IDENTIFIER id X PPTOKEN *p )
1624
{
1625
    int t ;
1626
    int d = 0 ;
1627
    int ok = 1 ;
1628
    PARSE_STATE st ;
1629
    unsigned m = 0 ;
1630
    int started = 0 ;
1631
    LIST ( TOKEN ) args ;
1632
    ERROR err = NULL_err ;
1633
    TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
1634
    LIST ( IDENTIFIER ) pids = DEREF_list ( tok_proc_pids ( tok ) ) ;
1635
    LIST ( IDENTIFIER ) bids = DEREF_list ( tok_proc_bids ( tok ) ) ;
1636
    unsigned n = LENGTH_list ( pids ) ;
1637
 
1638
    /* Initialise parser */
1639
    save_state ( &st, 1 ) ;
1640
    init_parser ( p ) ;
1641
    ADVANCE_LEXER ;
1642
    t = crt_lex_token ;
1643
    if ( t == lex_open_Hround || t == lex_open_Htemplate ) {
1644
	ADVANCE_LEXER ;
1645
    }
1646
    if ( IS_NULL_list ( pids ) ) {
1647
	/* Empty parameter list */
1648
	t = crt_lex_token ;
1649
	if ( t == lex_close_Hround || t == lex_close_Htemplate ) {
1650
	    ADVANCE_LEXER ;
1651
	}
1652
    } else {
1653
	/* Non-empty parameter list */
1654
	while ( !IS_NULL_list ( pids ) ) {
1655
	    IDENTIFIER pid = DEREF_id ( HEAD_list ( pids ) ) ;
1656
	    if ( !IS_NULL_id ( pid ) ) {
1657
		TYPE mt = NULL_type ;
1658
		t = crt_lex_token ;
1659
		if ( t == lex_close_Hround || t == lex_close_Htemplate ) {
1660
		    ADVANCE_LEXER ;
1661
		    break ;
1662
		}
1663
		if ( started ) {
1664
		    /* Each argument deduction is (nearly) independent */
1665
		    mt = expand_member_type ( pid ) ;
1666
		    d = save_token_args ( bids, NULL_list ( TOKEN ) ) ;
1667
		}
1668
		if ( !parse_token ( pid, mt, 1, 0, bids ) ) ok = 0 ;
1669
		if ( started ) {
1670
		    /* Combine argument deductions */
1671
		    IGNORE merge_token_args ( bids, d, 2 ) ;
1672
		}
1673
		started = 1 ;
1674
		if ( have_syntax_error ) {
1675
		    ok = 0 ;
1676
		    break ;
1677
		}
1678
	    } else {
1679
		ok = 0 ;
1680
		break ;
1681
	    }
1682
	    m++ ;
1683
	    t = crt_lex_token ;
1684
	    if ( t == lex_close_Hround || t == lex_close_Htemplate ) {
1685
		ADVANCE_LEXER ;
1686
		break ;
1687
	    }
1688
	    pids = TAIL_list ( pids ) ;
1689
	    if ( !IS_NULL_list ( pids ) ) {
1690
		if ( t == lex_comma ) {
1691
		    ADVANCE_LEXER ;
1692
		} else {
1693
		    report ( crt_loc, ERR_lex_expect ( lex_comma ) ) ;
1694
		}
1695
	    }
1696
	}
1697
    }
1698
 
1699
    /* Check for end of arguments */
1700
    if ( ok ) {
1701
	t = crt_lex_token ;
1702
	if ( t == lex_comma ) {
1703
	    m = n + 1 ;
1704
	} else if ( t != lex_eof ) {
1705
	    ERROR err2 = ERR_lex_parse ( crt_token ) ;
1706
	    report ( crt_loc, err2 ) ;
1707
	    ok = 0 ;
1708
	}
1709
	if ( ok && m != n ) {
1710
	    HASHID nm = DEREF_hashid ( id_name ( id ) ) ;
1711
	    ERROR err2 = ERR_cpp_replace_arg_number ( nm, m, m, n ) ;
1712
	    report ( crt_loc, err2 ) ;
1713
	}
1714
	IGNORE check_value ( OPT_VAL_macro_args, ( ulong ) m ) ;
1715
    }
1716
 
1717
    /* Restore state */
1718
    restore_state ( &st ) ;
1719
    p = restore_parser () ;
1720
    free_tok_list ( p ) ;
1721
 
1722
    /* Construct token arguments */
1723
    args = make_token_args ( id, bids, &err ) ;
1724
    if ( !IS_NULL_err ( err ) ) {
1725
	if ( ok ) {
1726
	    report ( crt_loc, err ) ;
1727
	} else {
1728
	    destroy_error ( err, 1 ) ;
1729
	}
1730
    }
1731
    return ( args ) ;
1732
}
1733
 
1734
 
1735
/*
1736
    PARSE AN EXPRESSION TOKEN
1737
 
1738
    This routine applies the expression procedure token id to the
1739
    arguments given by the preprocessing tokens p.
1740
*/
1741
 
1742
EXP parse_exp_token
1743
    PROTO_N ( ( id, p ) )
1744
    PROTO_T ( IDENTIFIER id X PPTOKEN *p )
1745
{
1746
    EXP e ;
1747
    LIST ( TOKEN ) args ;
1748
    TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
1749
    LIST ( IDENTIFIER ) bids = DEREF_list ( tok_proc_bids ( tok ) ) ;
1750
    int d = save_token_args ( bids, NULL_list ( TOKEN ) ) ;
1751
    args = parse_token_args ( id, p ) ;
1752
    e = apply_exp_token ( id, args, 2 ) ;
1753
    restore_token_args ( bids, d ) ;
1754
    return ( e ) ;
1755
}
1756
 
1757
 
1758
/*
1759
    PARSE A TYPE TOKEN
1760
 
1761
    This routine applies the type procedure token id to the arguments
1762
    given by the preprocessing tokens p.
1763
*/
1764
 
1765
TYPE parse_type_token
1766
    PROTO_N ( ( id, p ) )
1767
    PROTO_T ( IDENTIFIER id X PPTOKEN *p )
1768
{
1769
    TYPE t ;
1770
    if ( IS_id_token ( id ) ) {
1771
	/* Type token */
1772
	LIST ( TOKEN ) args ;
1773
	TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
1774
	LIST ( IDENTIFIER ) bids = DEREF_list ( tok_proc_bids ( tok ) ) ;
1775
	int d = save_token_args ( bids, NULL_list ( TOKEN ) ) ;
1776
	args = parse_token_args ( id, p ) ;
1777
	t = apply_type_token ( id, args, NULL_id ) ;
1778
	restore_token_args ( bids, d ) ;
1779
    } else {
1780
	/* Typedef template */
1781
	t = parse_typedef_templ ( id, p ) ;
1782
    }
1783
    return ( t ) ;
1784
}
1785
 
1786
 
1787
/*
1788
    PARSE A MEMBER TOKEN
1789
 
1790
    This routine applies the member procedure token id to the arguments
1791
    given by the preprocessing tokens p.
1792
*/
1793
 
1794
OFFSET parse_mem_token
1795
    PROTO_N ( ( id, p ) )
1796
    PROTO_T ( IDENTIFIER id X PPTOKEN *p )
1797
{
1798
    OFFSET off ;
1799
    LIST ( TOKEN ) args ;
1800
    TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
1801
    LIST ( IDENTIFIER ) bids = DEREF_list ( tok_proc_bids ( tok ) ) ;
1802
    int d = save_token_args ( bids, NULL_list ( TOKEN ) ) ;
1803
    args = parse_token_args ( id, p ) ;
1804
    off = apply_mem_token ( id, args ) ;
1805
    restore_token_args ( bids, d ) ;
1806
    return ( off ) ;
1807
}
1808
 
1809
 
1810
/*
1811
    DEFINE A TOKEN USING A MACRO
1812
 
1813
    This routine defines the tokenised object id by means of the macro
1814
    mid.  It returns true if this is possible.
1815
*/
1816
 
1817
int define_token_macro
1818
    PROTO_N ( ( id, mid ) )
1819
    PROTO_T ( IDENTIFIER id X IDENTIFIER mid )
1820
{
1821
    DECL_SPEC fds = DEREF_dspec ( id_storage ( id ) ) ;
1822
    IDENTIFIER tid = find_token ( id ) ;
1823
    if ( IS_id_token ( tid ) ) {
1824
	int fn = 1 ;
1825
	PPTOKEN *p ;
1826
	PPTOKEN *r ;
1827
	LOCATION loc ;
1828
	PARSE_STATE st ;
1829
	STACK ( EXP ) tries ;
1830
	LIST ( IDENTIFIER ) pids ;
1831
	LIST ( TYPE ) ex = univ_type_set ;
1832
	TOKEN tok = DEREF_tok ( id_token_sort ( tid ) ) ;
1833
	DECL_SPEC ds = DEREF_dspec ( id_storage ( tid ) ) ;
1834
 
1835
	/* Find token definition */
1836
	if ( IS_id_obj_macro ( mid ) ) {
1837
	    switch ( TAG_tok ( tok ) ) {
1838
		case tok_func_tag : {
1839
		    /* Function tokens read as identifiers */
1840
		    IGNORE find_func_token ( id, ( unsigned ) UINT_MAX ) ;
1841
		    COPY_dspec ( id_storage ( id ), ( fds & ~dspec_token ) ) ;
1842
		    fn = 0 ;
1843
		    break ;
1844
		}
1845
		case tok_templ_tag :
1846
		case tok_proc_tag : {
1847
		    /* Can't have procedure tokens */
1848
		    report ( preproc_loc, ERR_token_def_args ( id ) ) ;
1849
		    return ( 1 ) ;
1850
		}
1851
	    }
1852
	    p = DEREF_pptok ( id_obj_macro_defn ( mid ) ) ;
1853
	} else {
1854
	    unsigned n = DEREF_unsigned ( id_func_macro_no_params ( mid ) ) ;
1855
	    switch ( TAG_tok ( tok ) ) {
1856
		case tok_func_tag : {
1857
		    /* Find function token with n parameters */
1858
		    TYPE t = DEREF_type ( tok_func_type ( tok ) ) ;
1859
		    tid = find_func_token ( id, n ) ;
1860
		    if ( IS_NULL_id ( tid ) ) {
1861
			report ( preproc_loc, ERR_token_def_args ( id ) ) ;
1862
			return ( 1 ) ;
1863
		    }
1864
		    tok = DEREF_tok ( id_token_sort ( tid ) ) ;
1865
		    tok = func_proc_token ( tok ) ;
1866
		    id = DEREF_id ( id_token_alt ( tid ) ) ;
1867
		    fds = DEREF_dspec ( id_storage ( id ) ) ;
1868
		    COPY_dspec ( id_storage ( id ), ( fds & ~dspec_token ) ) ;
1869
		    ex = DEREF_list ( type_func_except ( t ) ) ;
1870
		    break ;
1871
		}
1872
		case tok_proc_tag : {
1873
		    /* Procedure tokens */
1874
		    pids = DEREF_list ( tok_proc_pids ( tok ) ) ;
1875
		    if ( LENGTH_list ( pids ) != n ) {
1876
			report ( preproc_loc, ERR_token_def_args ( id ) ) ;
1877
			return ( 1 ) ;
1878
		    }
1879
		    break ;
1880
		}
1881
		default : {
1882
		    /* Can't have simple tokens */
1883
		    report ( preproc_loc, ERR_token_def_args ( id ) ) ;
1884
		    return ( 1 ) ;
1885
		}
1886
	    }
1887
	    p = DEREF_pptok ( id_func_macro_defn ( mid ) ) ;
1888
	}
1889
 
1890
	/* Expand token definition */
1891
	p = expand_tok_list ( p ) ;
1892
	r = new_pptok () ;
1893
	r->tok = lex_newline ;
1894
	r->next = NULL ;
1895
	if ( p == NULL ) {
1896
	    p = r ;
1897
	} else {
1898
	    PPTOKEN *q = p ;
1899
	    while ( q->next ) q = q->next ;
1900
	    q->next = r ;
1901
	}
1902
 
1903
	/* Allow for procedure tokens */
1904
	if ( IS_tok_proc ( tok ) ) {
1905
	    NAMESPACE ns ;
1906
	    PPTOKEN *q = p ;
1907
	    pids = DEREF_list ( tok_proc_pids ( tok ) ) ;
1908
	    while ( q != NULL ) {
1909
		if ( q->tok == lex_macro_Harg ) {
1910
		    unsigned long pn = q->pp_data.par.no - 1 ;
1911
		    LIST ( IDENTIFIER ) qids = pids ;
1912
		    while ( pn && !IS_NULL_list ( qids ) ) {
1913
			qids = TAIL_list ( qids ) ;
1914
			pn-- ;
1915
		    }
1916
		    if ( !IS_NULL_list ( qids ) ) {
1917
			IDENTIFIER qid = DEREF_id ( HEAD_list ( qids ) ) ;
1918
			if ( !IS_NULL_id ( qid ) ) {
1919
			    HASHID qnm = DEREF_hashid ( id_name ( qid ) ) ;
1920
			    q->tok = lex_identifier ;
1921
			    q->pp_data.id.hash = qnm ;
1922
			    q->pp_data.id.use = qid ;
1923
			}
1924
		    }
1925
		}
1926
		q = q->next ;
1927
	    }
1928
	    pids = DEREF_list ( tok_proc_bids ( tok ) ) ;
1929
	    while ( !IS_NULL_list ( pids ) ) {
1930
		IDENTIFIER pid = DEREF_id ( HEAD_list ( pids ) ) ;
1931
		if ( !IS_NULL_id ( pid ) ) {
1932
		    DECL_SPEC pds = DEREF_dspec ( id_storage ( pid ) ) ;
1933
		    pds |= dspec_pure ;
1934
		    COPY_dspec ( id_storage ( pid ), pds ) ;
1935
		}
1936
		pids = TAIL_list ( pids ) ;
1937
	    }
1938
	    ns = DEREF_nspace ( tok_proc_pars ( tok ) ) ;
1939
	    add_namespace ( ns ) ;
1940
	}
1941
 
1942
	/* Parse token */
1943
	loc = crt_loc ;
1944
	bad_crt_loc++ ;
1945
	crt_loc = preproc_loc ;
1946
	tries = crt_try_blocks ;
1947
	start_try_check ( ex ) ;
1948
	save_state ( &st, 0 ) ;
1949
	init_parser ( p ) ;
1950
	ADVANCE_LEXER ;
1951
	pids = NULL_list ( IDENTIFIER ) ;
1952
	IGNORE parse_token ( tid, NULL_type, fn, 1, pids ) ;
1953
	if ( !have_syntax_error && crt_lex_token != lex_newline ) {
1954
	    ERROR err = ERR_lex_parse ( crt_token ) ;
1955
	    report ( crt_loc, err ) ;
1956
	}
1957
	if ( ds & dspec_pure ) {
1958
	    report ( preproc_loc, ERR_token_def_not ( id ) ) ;
1959
	} else {
1960
	    if ( do_dump ) dump_declare ( id, &crt_loc, 1 ) ;
1961
	}
1962
	restore_state ( &st ) ;
1963
	p = restore_parser () ;
1964
	free_tok_list ( p ) ;
1965
	IGNORE end_try_check ( id, NULL_exp ) ;
1966
	crt_try_blocks = tries ;
1967
	crt_loc = loc ;
1968
	bad_crt_loc-- ;
1969
 
1970
	/* Allow for procedure tokens */
1971
	if ( IS_tok_proc ( tok ) ) {
1972
	    remove_namespace () ;
1973
	    pids = DEREF_list ( tok_proc_bids ( tok ) ) ;
1974
	    while ( !IS_NULL_list ( pids ) ) {
1975
		IDENTIFIER pid = DEREF_id ( HEAD_list ( pids ) ) ;
1976
		if ( !IS_NULL_id ( pid ) ) {
1977
		    DECL_SPEC pds = DEREF_dspec ( id_storage ( pid ) ) ;
1978
		    pds &= ~dspec_pure ;
1979
		    COPY_dspec ( id_storage ( pid ), pds ) ;
1980
		}
1981
		pids = TAIL_list ( pids ) ;
1982
	    }
1983
	}
1984
	COPY_dspec ( id_storage ( id ), fds ) ;
1985
	return ( 1 ) ;
1986
    }
1987
    return ( 0 ) ;
1988
}
1989
 
1990
 
1991
/*
1992
    DEFINE A MEMBER TOKEN
1993
 
1994
    This routine is used to define the tokenised member id of t by the
1995
    list of immediately following preprocessing tokens.  This is used
1996
    to implement the '#pragma TenDRA member definition' command.
1997
*/
1998
 
1999
int define_mem_macro
2000
    PROTO_N ( ( id, t ) )
2001
    PROTO_T ( IDENTIFIER id X TYPE t )
2002
{
2003
    IDENTIFIER tid = tok_member ( id, t, 0 ) ;
2004
    if ( !IS_NULL_id ( tid ) ) {
2005
	id = tid ;
2006
	tid = find_token ( tid ) ;
2007
	if ( !IS_NULL_id ( tid ) && IS_id_token ( tid ) ) {
2008
	    TOKEN tok = DEREF_tok ( id_token_sort ( tid ) ) ;
2009
	    if ( IS_tok_member ( tok ) ) {
2010
		int def ;
2011
		LOCATION loc ;
2012
		DECL_SPEC ds = DEREF_dspec ( id_storage ( tid ) ) ;
2013
		LIST ( IDENTIFIER ) pids = NULL_list ( IDENTIFIER ) ;
2014
		bad_crt_loc++ ;
2015
		loc = crt_loc ;
2016
		crt_loc = preproc_loc ;
2017
		def = parse_token ( tid, NULL_type, 1, 1, pids ) ;
2018
		if ( ds & dspec_pure ) {
2019
		    report ( preproc_loc, ERR_token_def_not ( id ) ) ;
2020
		} else {
2021
		    if ( do_dump ) dump_declare ( id, &crt_loc, 1 ) ;
2022
		}
2023
		crt_loc = loc ;
2024
		bad_crt_loc-- ;
2025
		return ( def ) ;
2026
	    }
2027
	}
2028
	report ( preproc_loc, ERR_token_undecl ( id ) ) ;
2029
    }
2030
    if ( in_preproc_dir ) IGNORE skip_to_end () ;
2031
    return ( 0 ) ;
2032
}
2033
 
2034
 
2035
/*
2036
    PENDING TOKEN FOR IDENTIFIER UNIFICATION
2037
 
2038
    The normal unification routine is called immediately after the
2039
    declaration of an object.  However for 'const' objects it is more
2040
    useful to postpone the unification until after the initialisation.
2041
*/
2042
 
2043
IDENTIFIER unify_id_pending = NULL_id ;
2044
 
2045
 
2046
/*
2047
    UNIFY TWO IDENTIFIERS
2048
 
2049
    This routine is called whenever an identifier id hides an identifier
2050
    pid from the same namespace.  Normally this is a redeclaration error
2051
    which will have been caught by the declaration routines, however if
2052
    pid is a token identifier it may be a token definition.  The routine
2053
    returns true if this is the case.
2054
*/
2055
 
2056
int unify_id
2057
    PROTO_N ( ( pid, id, def ) )
2058
    PROTO_T ( IDENTIFIER pid X IDENTIFIER id X int def )
2059
{
2060
    int ok = 0 ;
2061
    IDENTIFIER tid = DEREF_id ( id_token_alt ( pid ) ) ;
2062
    if ( IS_id_token ( tid ) ) {
2063
	/* Previous definition was a token */
2064
	TOKEN tok = DEREF_tok ( id_token_sort ( tid ) ) ;
2065
	switch ( TAG_tok ( tok ) ) {
2066
	    case tok_exp_tag :
2067
	    case tok_nat_tag :
2068
	    case tok_snat_tag : {
2069
		/* Expression tokens */
2070
		EXP e ;
2071
		int expl = 0 ;
2072
		switch ( TAG_id ( id ) ) {
2073
		    case id_variable_tag : {
2074
#if LANGUAGE_CPP
2075
			TYPE t = DEREF_type ( id_variable_type ( id ) ) ;
2076
			CV_SPEC cv = DEREF_cv ( type_qual ( t ) ) ;
2077
			if ( cv == ( cv_lvalue | cv_const ) ) {
2078
			    /* Allow for const objects */
2079
			    e = DEREF_exp ( id_variable_init ( id ) ) ;
2080
			    if ( IS_NULL_exp ( e ) ) {
2081
				if ( IS_NULL_id ( unify_id_pending ) ) {
2082
				    unify_id_pending = pid ;
2083
				    return ( 1 ) ;
2084
				}
2085
			    }
2086
			}
2087
#endif
2088
			unify_id_pending = NULL_id ;
2089
			goto variable_label ;
2090
		    }
2091
		    case id_enumerator_tag : {
2092
			expl = 1 ;
2093
			goto variable_label ;
2094
		    }
2095
		    variable_label :
2096
		    case id_parameter_tag :
2097
		    case id_stat_member_tag : {
2098
			e = make_id_exp ( id ) ;
2099
			if ( define_exp_token ( tid, e, expl ) ) {
2100
			    LOCATION loc ;
2101
			    DEREF_loc ( id_loc ( id ), loc ) ;
2102
			    COPY_loc ( id_loc ( tid ), loc ) ;
2103
			}
2104
			ok = 1 ;
2105
			break ;
2106
		    }
2107
		}
2108
		break ;
2109
	    }
2110
	}
2111
	if ( ok ) {
2112
	    /* Set alternate look-up for token */
2113
	    HASHID nm = DEREF_hashid ( id_name ( tid ) ) ;
2114
	    MEMBER mem = search_member ( token_namespace, nm, 0 ) ;
2115
	    if ( !IS_NULL_member ( mem ) ) {
2116
		COPY_id ( member_alt ( mem ), id ) ;
2117
	    }
2118
	}
2119
    }
2120
    if ( ok ) {
2121
	/* Token definition */
2122
	DECL_SPEC ds = DEREF_dspec ( id_storage ( tid ) ) ;
2123
	if ( ds & dspec_pure ) {
2124
	    report ( crt_loc, ERR_token_def_not ( pid ) ) ;
2125
	} else {
2126
	    if ( do_dump ) dump_declare ( pid, &crt_loc, 1 ) ;
2127
	}
2128
    } else {
2129
	/* Illegal redeclaration */
2130
	if ( def ) id = pid ;
2131
	report ( crt_loc, ERR_basic_odr_diff ( id, id_loc ( id ) ) ) ;
2132
    }
2133
    return ( ok ) ;
2134
}