Rev 2 | Blame | Compare with Previous | Last modification | View Log | RSS feed
/*
Crown Copyright (c) 1997, 1998
This TenDRA(r) Computer Program is subject to Copyright
owned by the United Kingdom Secretary of State for Defence
acting through the Defence Evaluation and Research Agency
(DERA). It is made available to Recipients with a
royalty-free licence for its use, reproduction, transfer
to other parties and amendment for any purpose not excluding
product development provided that any such use et cetera
shall be deemed to be acceptance of the following conditions:-
(1) Its Recipients shall ensure that this Notice is
reproduced upon any copies or amended versions of it;
(2) Any amended version of it shall be clearly marked to
show both the nature of and the organisation responsible
for the relevant amendment or amendments;
(3) Its onward transfer from a recipient to another
party shall be deemed to be that party's acceptance of
these conditions;
(4) DERA gives no warranty or assurance as to its
quality or suitability for any purpose and DERA accepts
no liability whatsoever in relation to any use to which
it may be put.
*/
#include "config.h"
#include <limits.h>
#include "c_types.h"
#include "ctype_ops.h"
#include "exp_ops.h"
#include "hashid_ops.h"
#include "id_ops.h"
#include "member_ops.h"
#include "nat_ops.h"
#include "nspace_ops.h"
#include "off_ops.h"
#include "tok_ops.h"
#include "type_ops.h"
#include "error.h"
#include "catalog.h"
#include "option.h"
#include "access.h"
#include "basetype.h"
#include "check.h"
#include "chktype.h"
#include "class.h"
#include "constant.h"
#include "convert.h"
#include "derive.h"
#include "dump.h"
#include "exception.h"
#include "expression.h"
#include "file.h"
#include "function.h"
#include "hash.h"
#include "identifier.h"
#include "initialise.h"
#include "inttype.h"
#include "lex.h"
#include "macro.h"
#include "member.h"
#include "namespace.h"
#include "overload.h"
#include "parse.h"
#include "predict.h"
#include "preproc.h"
#include "redeclare.h"
#include "statement.h"
#include "syntax.h"
#include "template.h"
#include "tokdef.h"
#include "token.h"
/*
TOKEN DEFINITION FLAG
Tokens are defined by the equality routines if the flag force_tokdef
is set. This is only done if we are reasonably sure that the equality
should hold. Similarly template specialisation is only considered
if force_template is true.
*/
int force_tokdef = 0 ;
int force_template = 0 ;
int expand_tokdef = 0 ;
/*
IS A TOKEN BEING DEFINED?
This routine uses the values force_tokdef and force_template to
determine whether the token id is available for token unification.
*/
int defining_token
PROTO_N ( ( id ) )
PROTO_T ( IDENTIFIER id )
{
if ( !IS_NULL_id ( id ) && IS_id_token ( id ) ) {
DECL_SPEC ds ;
if ( force_tokdef ) return ( 1 ) ;
ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( ds & dspec_template ) return ( force_template ) ;
}
return ( 0 ) ;
}
/*
FIND THE RESULT COMPONENT OF A TOKEN
This routine finds the result component of the token id.
*/
TOKEN find_tokdef
PROTO_N ( ( id ) )
PROTO_T ( IDENTIFIER id )
{
TOKEN tok = NULL_tok ;
if ( !IS_NULL_id ( id ) && IS_id_token ( id ) ) {
unsigned tag ;
tok = DEREF_tok ( id_token_sort ( id ) ) ;
tag = TAG_tok ( tok ) ;
if ( tag == tok_func_tag ) {
TOKEN ptok = DEREF_tok ( tok_func_proc ( tok ) ) ;
if ( !IS_NULL_tok ( ptok ) ) {
tok = DEREF_tok ( tok_proc_res ( ptok ) ) ;
}
} else if ( tag == tok_proc_tag ) {
tok = DEREF_tok ( tok_proc_res ( tok ) ) ;
}
}
return ( tok ) ;
}
/*
DUMMY TOKEN PARAMETER VALUES
These values are used to indicate that a token parameter has been
redefined inconsistently.
*/
static NAT redef_nat = NULL_nat ;
static EXP redef_exp = NULL_exp ;
TYPE redef_type = NULL_type ;
static IDENTIFIER redef_id = NULL_id ;
static OFFSET redef_off = NULL_off ;
/*
INITIALISE DUMMY TOKEN PARAMETER VALUES
This routine initialises the dummy token parameter values above.
They are set to impossible values which could not arise naturally.
*/
void init_token_args
PROTO_Z ()
{
HASHID nm = KEYWORD ( lex_error ) ;
redef_id = DEREF_id ( hashid_id ( nm ) ) ;
MAKE_type_ref ( cv_none, type_void, redef_type ) ;
MAKE_exp_value ( redef_type, redef_exp ) ;
MAKE_nat_calc ( redef_exp, redef_nat ) ;
MAKE_off_zero ( redef_type, redef_off ) ;
return ;
}
/*
DEFINE AN INTEGER CONSTANT TOKEN
This routine defines the integer constant token id to be e. It
returns true if the token is assigned a value.
*/
int define_nat_token
PROTO_N ( ( id, n ) )
PROTO_T ( IDENTIFIER id X NAT n )
{
if ( !IS_NULL_nat ( n ) ) {
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( !( ds & dspec_pure ) ) {
int ok = 1 ;
TOKEN tok = find_tokdef ( id ) ;
if ( IS_NULL_tok ( tok ) ) return ( 0 ) ;
switch ( TAG_tok ( tok ) ) {
case tok_nat_tag :
case tok_snat_tag : {
/* Integer constant tokens */
NAT m = DEREF_nat ( tok_nat_etc_value ( tok ) ) ;
if ( !IS_NULL_nat ( m ) && !eq_nat ( n, m ) ) {
if ( ds & dspec_auto ) {
n = redef_nat ;
} else {
PTR ( LOCATION ) loc = id_loc ( id ) ;
report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
}
ok = 0 ;
}
COPY_nat ( tok_nat_etc_value ( tok ), n ) ;
break ;
}
case tok_exp_tag :
case tok_stmt_tag : {
/* Expression tokens */
EXP e = calc_nat_value ( n, type_sint ) ;
return ( define_exp_token ( id, e, 1 ) ) ;
}
default : {
/* Other tokens */
return ( 0 ) ;
}
}
if ( !( ds & dspec_auto ) ) no_token_defns++ ;
ds |= dspec_defn ;
COPY_dspec ( id_storage ( id ), ds ) ;
COPY_loc ( id_loc ( id ), crt_loc ) ;
return ( ok ) ;
}
}
return ( 0 ) ;
}
/*
DEFINE AN EXPRESSION TOKEN
This routine defines the expression, statement or integer constant
token id to be e. It returns true if the token is assigned a value.
expl is false for an enforcing external declaration, such as that
arising from unify_id.
*/
int define_exp_token
PROTO_N ( ( id, e, expl ) )
PROTO_T ( IDENTIFIER id X EXP e X int expl )
{
if ( !IS_NULL_exp ( e ) ) {
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( !( ds & dspec_pure ) ) {
int ok = 1 ;
unsigned tt ;
TOKEN tok = find_tokdef ( id ) ;
if ( IS_NULL_tok ( tok ) ) return ( 0 ) ;
tt = TAG_tok ( tok ) ;
switch ( tt ) {
case tok_exp_tag : {
/* Expression tokens */
TYPE s ;
ERROR err = NULL_err ;
unsigned etag = TAG_exp ( e ) ;
EXP d = DEREF_exp ( tok_exp_value ( tok ) ) ;
int c = DEREF_int ( tok_exp_constant ( tok ) ) ;
TYPE t = DEREF_type ( tok_exp_type ( tok ) ) ;
CV_SPEC cv = DEREF_cv ( type_qual ( t ) ) ;
LIST ( IDENTIFIER ) pids = NULL_list ( IDENTIFIER ) ;
force_tokdef++ ;
e = convert_reference ( e, REF_ASSIGN ) ;
e = resolve_cast ( t, e, &err, 1, 0, pids ) ;
s = DEREF_type ( exp_type ( e ) ) ;
if ( cv & cv_lvalue ) {
/* lvalue tokens */
cv = DEREF_cv ( type_qual ( s ) ) ;
if ( cv & cv_lvalue ) {
if ( eq_type ( s, t ) ) {
if ( !IS_exp_address ( e ) ) {
MAKE_exp_address ( t, e, e ) ;
}
} else {
EXP a = init_ref_lvalue ( t, e, &err ) ;
if ( IS_NULL_exp ( a ) ) {
err = ERR_basic_link_incompat ( t, s ) ;
} else {
e = make_ref_init ( t, a ) ;
}
}
} else {
report ( crt_loc, ERR_token_arg_lvalue ( id ) ) ;
}
} else {
/* rvalue tokens */
if ( IS_exp_aggregate ( e ) ) {
/* Aggregate initialiser */
e = init_aggregate ( t, e, id, &err ) ;
} else {
switch ( TAG_type ( t ) ) {
case type_top_tag :
case type_bottom_tag : {
/* Void expressions */
e = convert_lvalue ( e ) ;
e = convert_none ( e ) ;
e = make_discard_exp ( e ) ;
if ( !IS_type_top_etc ( s ) ) {
EXP a = make_null_exp ( t ) ;
e = join_exp ( e, a ) ;
}
break ;
}
case type_ref_tag : {
/* Reference initialiser */
e = init_assign ( t, cv_none, e, &err ) ;
break ;
}
case type_array_tag : {
/* Array initialiser */
if ( etag == exp_paren_tag ) {
e = make_paren_exp ( e ) ;
}
e = init_array ( t, cv_none, e, 1, &err ) ;
break ;
}
case type_error_tag : {
e = convert_none ( e ) ;
break ;
}
default : {
/* Simple initialiser */
e = convert_lvalue ( e ) ;
e = init_assign ( t, cv_none, e, &err ) ;
break ;
}
}
}
}
force_tokdef-- ;
if ( !IS_NULL_err ( err ) ) {
/* Conversion error */
err = init_error ( err, 0 ) ;
err = concat_error ( err, ERR_token_arg_exp ( id ) ) ;
report ( crt_loc, err ) ;
}
if ( c == 1 && !is_const_exp ( e, 1 ) ) {
report ( crt_loc, ERR_token_arg_const ( id ) ) ;
}
if ( !IS_NULL_exp ( d ) && !eq_exp ( e, d, 0 ) ) {
int redef = 0 ;
if ( ds & dspec_auto ) {
e = redef_exp ;
} else {
if ( expl ) {
if ( ds & dspec_main ) {
redef = 1 ;
} else {
ds |= dspec_main ;
}
} else {
if ( ds & dspec_main ) {
e = d ;
} else {
redef = 1 ;
}
}
}
if ( redef ) {
PTR ( LOCATION ) loc = id_loc ( id ) ;
report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
ok = 0 ;
}
} else {
if ( expl && !( ds & dspec_auto ) ) {
/* Mark explicit definitions */
ds |= dspec_main ;
}
}
COPY_exp ( tok_exp_value ( tok ), e ) ;
break ;
}
case tok_nat_tag :
case tok_snat_tag : {
/* Constant tokens */
NAT n ;
ERROR err = NULL_err ;
e = convert_reference ( e, REF_NORMAL ) ;
e = convert_lvalue ( e ) ;
n = make_nat_exp ( e, &err ) ;
if ( !IS_NULL_err ( err ) ) {
/* Not a constant expression */
err = concat_error ( err, ERR_token_arg_nat ( id ) ) ;
report ( crt_loc, err ) ;
} else {
if ( tt == tok_nat_tag && is_negative_nat ( n ) ) {
/* Negative constant */
report ( crt_loc, ERR_token_arg_nat ( id ) ) ;
n = negate_nat ( n ) ;
}
}
return ( define_nat_token ( id, n ) ) ;
}
case tok_stmt_tag : {
/* Statement tokens */
EXP d = DEREF_exp ( tok_stmt_value ( tok ) ) ;
if ( !IS_NULL_exp ( d ) && !eq_exp ( e, d, 0 ) ) {
if ( ds & dspec_auto ) {
e = redef_exp ;
} else {
PTR ( LOCATION ) loc = id_loc ( id ) ;
report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
}
ok = 0 ;
}
COPY_exp ( tok_stmt_value ( tok ), e ) ;
break ;
}
default : {
/* Other tokens */
return ( 0 ) ;
}
}
if ( !( ds & dspec_auto ) ) no_token_defns++ ;
ds |= dspec_defn ;
COPY_dspec ( id_storage ( id ), ds ) ;
COPY_loc ( id_loc ( id ), crt_loc ) ;
return ( ok ) ;
}
}
return ( 0 ) ;
}
/*
DEFINE THE FIELDS OF A TYPE TOKEN
This routine is called when a tokenised structure or union id is defined
by the compound type t. It checks for any tokenised members of id
which may also be defined as a result of this identification. This
should really be done by the class merging routines.
*/
static void define_field_tokens
PROTO_N ( ( id, t ) )
PROTO_T ( IDENTIFIER id X TYPE t )
{
IDENTIFIER tid = DEREF_id ( id_token_alt ( id ) ) ;
unsigned tag = TAG_id ( tid ) ;
if ( tag == id_class_name_tag || tag == id_class_alias_tag ) {
TYPE s = DEREF_type ( id_class_name_etc_defn ( tid ) ) ;
if ( IS_type_compound ( s ) && IS_type_compound ( t ) ) {
MEMBER mem ;
CLASS_TYPE cs = DEREF_ctype ( type_compound_defn ( s ) ) ;
CLASS_TYPE ct = DEREF_ctype ( type_compound_defn ( t ) ) ;
NAMESPACE ns = DEREF_nspace ( ctype_member ( cs ) ) ;
NAMESPACE nt = DEREF_nspace ( ctype_member ( ct ) ) ;
/* Check that keys match for type aliases */
if ( tag == id_class_alias_tag ) {
BASE_TYPE bs = find_class_key ( cs ) ;
BASE_TYPE bt = find_class_key ( ct ) ;
if ( !equal_key ( bs, bt ) ) {
PTR ( LOCATION ) loc = id_loc ( id ) ;
ERROR err = ERR_dcl_type_elab_bad ( bt, bs, id, loc ) ;
report ( crt_loc, err ) ;
}
}
/* Scan through members of ns */
mem = DEREF_member ( nspace_ctype_first ( ns ) ) ;
while ( !IS_NULL_member ( mem ) ) {
IDENTIFIER mid = DEREF_id ( member_id ( mem ) ) ;
if ( !IS_NULL_id ( mid ) && IS_id_member ( mid ) ) {
DECL_SPEC ds = DEREF_dspec ( id_storage ( mid ) ) ;
if ( ds & dspec_token ) {
/* Tokenised member found */
HASHID nm = DEREF_hashid ( id_name ( mid ) ) ;
IDENTIFIER nid = search_field ( nt, nm, 0, 0 ) ;
if ( !IS_NULL_id ( nid ) ) {
/* Token definition found */
IDENTIFIER tok = find_token ( mid ) ;
ds = DEREF_dspec ( id_storage ( tok ) ) ;
if ( ds & dspec_pure ) {
LOCATION loc ;
DEREF_loc ( id_loc ( nid ), loc ) ;
report ( loc, ERR_token_def_not ( nid ) ) ;
} else {
OFFSET off ;
TYPE r = NULL_type ;
off = offset_member ( t, nid, &r, nt, 0 ) ;
IGNORE define_mem_token ( tok, off, r, 1 ) ;
}
} else {
/* Copy tokenised member */
MEMBER mem2 = search_member ( nt, nm, 1 ) ;
mid = copy_id ( mid, 0 ) ;
COPY_nspace ( id_parent ( mid ), nt ) ;
set_member ( mem2, mid ) ;
}
}
}
mem = DEREF_member ( member_next ( mem ) ) ;
}
/* Scan through members of nt */
mem = DEREF_member ( nspace_ctype_first ( nt ) ) ;
while ( !IS_NULL_member ( mem ) ) {
MEMBER mem2 = NULL_member ;
IDENTIFIER mid = DEREF_id ( member_id ( mem ) ) ;
IDENTIFIER nid = DEREF_id ( member_alt ( mem ) ) ;
if ( !IS_NULL_id ( mid ) ) {
IDENTIFIER pid ;
HASHID nm = DEREF_hashid ( id_name ( mid ) ) ;
mem2 = search_member ( ns, nm, 1 ) ;
mid = copy_id ( mid, 0 ) ;
COPY_nspace ( id_parent ( mid ), ns ) ;
pid = DEREF_id ( member_id ( mem2 ) ) ;
if ( IS_NULL_id ( pid ) ) {
set_member ( mem2, mid ) ;
}
}
if ( !IS_NULL_id ( nid ) && !EQ_id ( mid, nid ) ) {
if ( IS_NULL_member ( mem2 ) ) {
HASHID nm = DEREF_hashid ( id_name ( nid ) ) ;
mem2 = search_member ( ns, nm, 1 ) ;
}
nid = copy_id ( nid, 0 ) ;
COPY_nspace ( id_parent ( nid ), ns ) ;
if ( !IS_NULL_id ( nid ) ) {
set_type_member ( mem2, mid ) ;
}
}
mem = DEREF_member ( member_next ( mem ) ) ;
}
}
}
return ;
}
/*
CHECK A TYPE CATEGORY
This routine checks whether the type t of category ca can be used to
define a token of kind bt.
*/
static int match_type_token
PROTO_N ( ( bt, ca, t ) )
PROTO_T ( BASE_TYPE bt X unsigned ca X TYPE t )
{
int ok = 1 ;
if ( bt & btype_star ) {
/* Scalar types */
if ( !IS_TYPE_SCALAR ( ca ) ) ok = 0 ;
} else if ( bt & btype_float ) {
/* Arithmetic types */
if ( bt & btype_int ) {
if ( !IS_TYPE_ARITH ( ca ) ) ok = 0 ;
} else {
if ( !IS_TYPE_FLOAT ( ca ) ) ok = 0 ;
}
} else if ( bt & btype_int ) {
/* Integral types */
if ( IS_TYPE_INT ( ca ) ) {
if ( bt & btype_signed ) {
if ( check_int_type ( t, btype_unsigned ) ) ok = 0 ;
} else if ( bt & btype_unsigned ) {
if ( check_int_type ( t, btype_signed ) ) ok = 0 ;
}
} else {
ok = 0 ;
}
}
return ( ok ) ;
}
/*
DEFINE A TYPE TOKEN
This routine defines the type token id to be t. It returns true if
the token is assigned a value. qual is as in check_compatible.
*/
int define_type_token
PROTO_N ( ( id, t, qual ) )
PROTO_T ( IDENTIFIER id X TYPE t X int qual )
{
if ( !IS_NULL_type ( t ) ) {
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( !( ds & dspec_pure ) ) {
TYPE s ;
int ok = 1 ;
int check_promote = 0 ;
TOKEN tok = find_tokdef ( id ) ;
if ( IS_NULL_tok ( tok ) || !IS_tok_type ( tok ) ) return ( 0 ) ;
s = DEREF_type ( tok_type_value ( tok ) ) ;
if ( !IS_NULL_type ( s ) ) {
ERROR err = NULL_err ;
t = check_compatible ( s, t, qual, &err, 1 ) ;
if ( !IS_NULL_err ( err ) ) {
if ( ds & dspec_auto ) {
destroy_error ( err, 1 ) ;
t = redef_type ;
} else {
ERROR err2 ;
err2 = ERR_token_redef ( id, id_loc ( id ) ) ;
err = concat_error ( err, err2 ) ;
report ( crt_loc, err ) ;
}
ok = 0 ;
}
} else {
unsigned ca = type_category ( &t ) ;
BASE_TYPE bt = DEREF_btype ( tok_type_kind ( tok ) ) ;
if ( !( bt & btype_template ) ) {
/* Tokens */
ERROR err = NULL_err ;
switch ( TAG_type ( t ) ) {
case type_ref_tag :
case type_func_tag :
case type_bitfield_tag : {
/* These types can't be tokenised */
ok = 0 ;
break ;
}
case type_compound_tag : {
/* Can only tokenise trivial classes */
if ( bt != btype_none || !( ds & dspec_auto ) ) {
CLASS_TYPE ct ;
ct = DEREF_ctype ( type_compound_defn ( t ) ) ;
err = check_trivial_class ( ct ) ;
if ( !IS_NULL_err ( err ) ) ok = 0 ;
}
break ;
}
}
if ( bt ) {
if ( bt & btype_named ) {
/* Structure and union types */
if ( IS_type_compound ( t ) ) {
if ( !( ds & dspec_auto ) ) {
/* Check structure fields */
define_field_tokens ( id, t ) ;
}
} else {
ok = 0 ;
}
} else {
/* Check scalar types */
if ( !match_type_token ( bt, ca, t ) ) ok = 0 ;
}
if ( bt & btype_int ) check_promote = ok ;
}
if ( !ok ) {
/* Report any type mismatch errors */
if ( !IS_type_error ( t ) ) {
int lex = type_token_key ( bt ) ;
ERROR err2 = ERR_token_arg_type ( lex, id, t ) ;
err = concat_error ( err, err2 ) ;
report ( crt_loc, err ) ;
t = type_error ;
}
}
}
if ( !IS_TYPE_INT ( ca ) ) check_promote = 0 ;
}
COPY_type ( tok_type_value ( tok ), t ) ;
if ( ds & dspec_auto ) {
check_promote = 0 ;
} else {
no_token_defns++ ;
}
ds |= dspec_defn ;
COPY_dspec ( id_storage ( id ), ds ) ;
COPY_loc ( id_loc ( id ), crt_loc ) ;
if ( check_promote ) {
/* Check that promoted types are compatible */
s = apply_itype_token ( id, NULL_list ( TOKEN ) ) ;
t = promote_type ( t ) ;
set_promote_type ( s, t, ntype_none ) ;
}
return ( ok ) ;
}
}
return ( 0 ) ;
}
/*
DEFINE A TEMPLATE TEMPLATE PARAMETER
This routine defines the template template parameter id to be the
class given by tid. It returns true if the parameter is assigned a
value.
*/
int define_templ_token
PROTO_N ( ( id, tid ) )
PROTO_T ( IDENTIFIER id X IDENTIFIER tid )
{
if ( !IS_NULL_id ( tid ) ) {
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( !( ds & dspec_pure ) ) {
TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
if ( IS_tok_class ( tok ) ) {
int ok = 0 ;
IDENTIFIER sid = DEREF_id ( tok_class_value ( tok ) ) ;
if ( EQ_id ( sid, tid ) ) return ( 1 ) ;
if ( IS_id_class_name_etc ( tid ) ) {
TYPE t = DEREF_type ( tok_class_type ( tok ) ) ;
TYPE s = DEREF_type ( id_class_name_etc_defn ( tid ) ) ;
if ( IS_type_templ ( t ) && IS_type_templ ( s ) ) {
/* Check for equality of template parameters */
LIST ( IDENTIFIER ) ps, pt ;
TOKEN as = DEREF_tok ( type_templ_sort ( s ) ) ;
TOKEN at = DEREF_tok ( type_templ_sort ( t ) ) ;
ps = DEREF_list ( tok_templ_pids ( as ) ) ;
pt = DEREF_list ( tok_templ_pids ( at ) ) ;
ok = eq_templ_params ( ps, pt ) ;
restore_templ_params ( ps ) ;
}
if ( !ok ) {
/* Report illegal definitions */
ERROR err = ERR_temp_arg_templ_bad ( id, s ) ;
report ( crt_loc, err ) ;
}
if ( !IS_NULL_id ( sid ) ) {
/* Check for redefinitions */
if ( ds & dspec_auto ) {
tid = redef_id ;
} else {
PTR ( LOCATION ) loc = id_loc ( id ) ;
report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
}
ok = 0 ;
}
} else {
ok = 0 ;
}
COPY_id ( tok_class_value ( tok ), tid ) ;
if ( !( ds & dspec_auto ) ) no_token_defns++ ;
ds |= dspec_defn ;
COPY_dspec ( id_storage ( id ), ds ) ;
COPY_loc ( id_loc ( id ), crt_loc ) ;
return ( ok ) ;
}
}
}
return ( 0 ) ;
}
/*
DEFINE A MEMBER TOKEN
This routine defines the member token id to be a member of offset off
and type t. It returns true if the token is assigned a value. ext is
true for an external token definition.
*/
int define_mem_token
PROTO_N ( ( id, off, t, ext ) )
PROTO_T ( IDENTIFIER id X OFFSET off X TYPE t X int ext )
{
if ( !IS_NULL_off ( off ) ) {
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( ( ds & dspec_auto ) && ext ) {
ERROR err = ERR_class_mem_redecl ( id, id_loc ( id ) ) ;
report ( crt_loc, err ) ;
} else if ( !( ds & dspec_pure ) ) {
TOKEN tok = find_tokdef ( id ) ;
if ( !IS_NULL_tok ( tok ) && IS_tok_member ( tok ) ) {
TYPE u ;
ERROR err = NULL_err ;
TYPE s = DEREF_type ( tok_member_type ( tok ) ) ;
OFFSET d = DEREF_off ( tok_member_value ( tok ) ) ;
if ( !IS_NULL_off ( d ) && !eq_offset ( off, d, 0 ) ) {
if ( ds & dspec_auto ) {
off = redef_off ;
} else {
PTR ( LOCATION ) loc = id_loc ( id ) ;
report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
}
}
u = check_compatible ( s, t, 0, &err, 0 ) ;
if ( !IS_NULL_err ( err ) ) {
/* Member type is wrong */
if ( eq_type_offset ( s, t ) ) {
/* Types have same representation */
err = set_severity ( err, OPT_member_incompat, -1 ) ;
}
err = concat_error ( err, ERR_token_arg_mem ( id ) ) ;
report ( crt_loc, err ) ;
}
COPY_off ( tok_member_value ( tok ), off ) ;
if ( !( ds & dspec_auto ) ) {
if ( IS_type_error ( s ) ) {
/* Fill in type if not known */
IDENTIFIER mid = DEREF_id ( id_token_alt ( id ) ) ;
COPY_type ( tok_member_type ( tok ), u ) ;
u = lvalue_type ( u ) ;
COPY_type ( id_member_type ( mid ), u ) ;
}
no_token_defns++ ;
}
ds |= dspec_defn ;
COPY_dspec ( id_storage ( id ), ds ) ;
COPY_loc ( id_loc ( id ), crt_loc ) ;
UNUSED ( ext ) ;
return ( 1 ) ;
}
}
}
return ( 0 ) ;
}
/*
DEFINE A FUNCTION TOKEN
This routine defines the function token id to be the function fid.
*/
int define_func_token
PROTO_N ( ( id, fid ) )
PROTO_T ( IDENTIFIER id X IDENTIFIER fid )
{
if ( !IS_NULL_id ( fid ) ) {
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
if ( !( ds & dspec_pure ) ) {
TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
if ( IS_tok_func ( tok ) ) {
int eq = 0 ;
int redef = 0 ;
LIST ( IDENTIFIER ) pids = NULL_list ( IDENTIFIER ) ;
TYPE t = DEREF_type ( tok_func_type ( tok ) ) ;
TOKEN res = DEREF_tok ( tok_func_proc ( tok ) ) ;
IDENTIFIER pid = DEREF_id ( tok_func_defn ( tok ) ) ;
IDENTIFIER qid = resolve_func ( fid, t, 1, 0, pids, &eq ) ;
if ( !IS_NULL_id ( qid ) ) {
switch ( TAG_id ( qid ) ) {
case id_function_tag :
case id_stat_mem_func_tag : {
use_id ( qid, 0 ) ;
break ;
}
default : {
qid = NULL_id ;
break ;
}
}
}
if ( IS_NULL_id ( qid ) ) {
report ( crt_loc, ERR_token_def_func ( fid, t ) ) ;
qid = fid ;
} else {
TYPE s = DEREF_type ( id_function_etc_type ( qid ) ) ;
if ( eq == 2 ) {
report ( crt_loc, ERR_dcl_link_conv () ) ;
}
if ( eq_except ( s, t ) != 2 ) {
report ( crt_loc, ERR_token_def_except () ) ;
}
}
if ( !IS_NULL_tok ( res ) ) {
/* Previously defined by macro */
redef = 1 ;
}
if ( !IS_NULL_id ( pid ) && !EQ_id ( pid, qid ) ) {
/* Previously defined by different function */
redef = 1 ;
}
if ( redef ) {
PTR ( LOCATION ) loc = id_loc ( id ) ;
report ( crt_loc, ERR_token_redef ( id, loc ) ) ;
}
COPY_id ( tok_func_defn ( tok ), qid ) ;
if ( !( ds & dspec_auto ) ) no_token_defns++ ;
ds |= dspec_defn ;
COPY_dspec ( id_storage ( id ), ds ) ;
COPY_loc ( id_loc ( id ), crt_loc ) ;
return ( 1 ) ;
}
}
}
return ( 0 ) ;
}
/*
PROCEDURE TOKEN FLAG
This variable is used to keep track of the depth of procedure token
arguments being read.
*/
int in_proc_token = 0 ;
/*
FIND A TOKEN MEMBER TYPE
If id represents a member token then this routine returns the type
of which id is a member, suitably expanded. Otherwise the null type
is returned. This represents the only barrier to doing argument
deduction in procedure tokens independently for each argument - if
a member parameter is a member of a previous structure parameter
(as in offsetof), we need to know the value of the structure
argument before we can decode the member argument.
*/
static TYPE expand_member_type
PROTO_N ( ( id ) )
PROTO_T ( IDENTIFIER id )
{
TYPE t = NULL_type ;
TOKEN tok = find_tokdef ( id ) ;
if ( !IS_NULL_tok ( tok ) && IS_tok_member ( tok ) ) {
t = DEREF_type ( tok_member_of ( tok ) ) ;
t = expand_type ( t, 1 ) ;
}
return ( t ) ;
}
/*
PARSE A TOKEN DEFINITION
This routine reads the definition of the token id. It returns true
if a value is assigned to the token. If mt is not null it is the
class type for a member token. fn is true for procedure tokens and
mac is true is true for macro token definitions.
*/
static int parse_token
PROTO_N ( ( id, t, fn, mac, pids ) )
PROTO_T ( IDENTIFIER id X TYPE t X int fn X int mac X
LIST ( IDENTIFIER ) pids )
{
int def ;
TOKEN tok = NULL_tok ;
unsigned tag = null_tag ;
if ( IS_id_token ( id ) ) {
/* Find token sort */
tok = DEREF_tok ( id_token_sort ( id ) ) ;
if ( fn ) tok = find_tokdef ( id ) ;
tag = TAG_tok ( tok ) ;
}
switch ( tag ) {
case tok_exp_tag :
case tok_nat_tag :
case tok_snat_tag : {
/* Expression tokens */
EXP e = NULL_exp ;
ERROR err = NULL_err ;
int tn = crt_lex_token ;
if ( mac && tn == lex_newline && tag == tok_exp_tag ) {
/* Map empty definition to default value */
TYPE s = DEREF_type ( tok_exp_type ( tok ) ) ;
e = init_empty ( s, cv_none, 1, &err ) ;
} else if ( mac && tn == lex_open_Hbrace_H1 ) {
parse_init ( id, &e ) ;
} else {
parse_exp ( &e ) ;
}
if ( !IS_NULL_exp ( e ) && tag == tok_exp_tag ) {
/* Deal with overloaded functions */
TYPE s = DEREF_type ( tok_exp_type ( tok ) ) ;
force_tokdef++ ;
e = resolve_cast ( s, e, &err, 1, 0, pids ) ;
if ( !IS_NULL_err ( err ) ) {
err = concat_error ( err, ERR_token_arg_exp ( id ) ) ;
report ( crt_loc, err ) ;
}
force_tokdef-- ;
}
def = define_exp_token ( id, e, 1 ) ;
break ;
}
case tok_stmt_tag : {
/* Statement tokens */
EXP e ;
EXP a = NULL_exp ;
int ic = in_class_defn ;
int fd = in_function_defn ;
int uc = unreached_code ;
TYPE r = crt_func_return ;
NAMESPACE bns = block_namespace ;
DECL_SPEC ds = DEREF_dspec ( id_storage ( id ) ) ;
IDENTIFIER fid = DEREF_id ( id_token_alt ( id ) ) ;
unreached_code = 0 ;
if ( fd ) {
if ( !( ds & dspec_auto ) ) {
/* Force return errors */
crt_func_return = NULL_type ;
}
} else {
/* Treat as dummy function definition */
in_class_defn = 0 ;
in_function_defn = fd + 1 ;
really_in_function_defn++ ;
begin_function ( fid ) ;
crt_func_return = NULL_type ;
}
block_namespace = NULL_nspace ;
e = begin_compound_stmt ( 1 ) ;
parse_stmt ( &a ) ;
e = add_compound_stmt ( e, a ) ;
e = end_compound_stmt ( e ) ;
if ( fd ) {
if ( ds & dspec_auto ) {
/* Set dummy parent statement */
MAKE_exp_token ( type_void, id, NULL_list ( TOKEN ), a ) ;
set_parent_stmt ( e, a ) ;
}
} else {
/* End dummy function definition */
if ( crt_access_list.pending ) {
IGNORE report_access ( fid ) ;
}
e = end_function ( fid, e ) ;
really_in_function_defn-- ;
in_function_defn = fd ;
in_class_defn = ic ;
}
unreached_code = uc ;
block_namespace = bns ;
crt_func_return = r ;
def = define_exp_token ( id, e, 1 ) ;
break ;
}
case tok_member_tag : {
/* Member tokens */
TYPE s = type_error ;
OFFSET off = NULL_off ;
if ( IS_NULL_type ( t ) ) t = expand_member_type ( id ) ;
parse_offset ( NULL_off, t, &off, &s ) ;
def = define_mem_token ( id, off, s, 0 ) ;
break ;
}
case tok_func_tag : {
/* Function tokens */
IDENTIFIER fid = NULL_id ;
parse_id ( &fid ) ;
def = define_func_token ( id, fid ) ;
break ;
}
default : {
/* Type tokens */
TYPE s = NULL_type ;
have_type_specifier = 0 ;
parse_type ( &s ) ;
if ( tag == tok_type_tag ) {
/* Simple type token */
def = define_type_token ( id, s, 0 ) ;
} else {
/* Complex type value */
TYPE r = DEREF_type ( id_class_name_etc_defn ( id ) ) ;
force_tokdef++ ;
def = eq_type ( r, s ) ;
if ( !def && !IS_NULL_type ( s ) ) {
ERROR err = ERR_token_arg_type ( lex_type_Hcap, id, s ) ;
report ( crt_loc, err ) ;
}
force_tokdef-- ;
}
break ;
}
}
return ( def ) ;
}
/*
SET A TOKEN VALUE
This routine sets the value of the token id to be arg.
*/
void assign_token
PROTO_N ( ( id, arg ) )
PROTO_T ( IDENTIFIER id X TOKEN arg )
{
if ( !IS_NULL_tok ( arg ) ) {
TOKEN sort = DEREF_tok ( id_token_sort ( id ) ) ;
unsigned na = TAG_tok ( arg ) ;
unsigned nb = TAG_tok ( sort ) ;
if ( nb == tok_proc_tag ) {
sort = DEREF_tok ( tok_proc_res ( sort ) ) ;
nb = TAG_tok ( sort ) ;
}
if ( na == nb ) {
switch ( na ) {
case tok_exp_tag : {
EXP e = DEREF_exp ( tok_exp_value ( arg ) ) ;
COPY_exp ( tok_exp_value ( sort ), e ) ;
break ;
}
case tok_nat_tag :
case tok_snat_tag : {
NAT n = DEREF_nat ( tok_nat_etc_value ( arg ) ) ;
COPY_nat ( tok_nat_etc_value ( sort ), n ) ;
break ;
}
case tok_stmt_tag : {
EXP e = DEREF_exp ( tok_stmt_value ( arg ) ) ;
COPY_exp ( tok_stmt_value ( sort ), e ) ;
break ;
}
case tok_member_tag : {
OFFSET off = DEREF_off ( tok_member_value ( arg ) ) ;
COPY_off ( tok_member_value ( sort ), off ) ;
break ;
}
case tok_type_tag : {
TYPE t = DEREF_type ( tok_type_value ( arg ) ) ;
COPY_type ( tok_type_value ( sort ), t ) ;
break ;
}
case tok_class_tag : {
IDENTIFIER cid = DEREF_id ( tok_class_value ( arg ) ) ;
COPY_id ( tok_class_value ( sort ), cid ) ;
break ;
}
}
}
}
return ;
}
/*
TOKEN ARGUMENT STACKS
These stacks are used to store the values of the token arguments to
allow for recursive token applications.
*/
static STACK ( EXP ) token_exp_stack = NULL_stack ( EXP ) ;
static STACK ( NAT ) token_nat_stack = NULL_stack ( NAT ) ;
static STACK ( EXP ) token_stmt_stack = NULL_stack ( EXP ) ;
static STACK ( OFFSET ) token_mem_stack = NULL_stack ( OFFSET ) ;
static STACK ( TYPE ) token_type_stack = NULL_stack ( TYPE ) ;
static STACK ( IDENTIFIER ) token_class_stack = NULL_stack ( IDENTIFIER ) ;
/*
SAVE TOKEN ARGUMENT VALUES
This routine saves the argument values for the token parameters pids
by pushing them onto the stacks above. The argument values set to those
stored in args, or the null value when these are exhausted. The routine
also clears the pure field of the token, returning 0 if they were
previously set.
*/
int save_token_args
PROTO_N ( ( pids, args ) )
PROTO_T ( LIST ( IDENTIFIER ) pids X LIST ( TOKEN ) args )
{
int depth = 1 ;
LIST ( IDENTIFIER ) bids = pids ;
while ( !IS_NULL_list ( bids ) ) {
IDENTIFIER bid = DEREF_id ( HEAD_list ( bids ) ) ;
/* Get argument token value */
TOKEN atok = NULL_tok ;
unsigned at = null_tag ;
if ( !IS_NULL_list ( args ) ) {
atok = DEREF_tok ( HEAD_list ( args ) ) ;
if ( !IS_NULL_tok ( atok ) ) at = TAG_tok ( atok ) ;
args = TAIL_list ( args ) ;
}
/* Save previous token value */
if ( !IS_NULL_id ( bid ) && IS_id_token ( bid ) ) {
DECL_SPEC ds ;
TOKEN btok = DEREF_tok ( id_token_sort ( bid ) ) ;
unsigned bt = TAG_tok ( btok ) ;
switch ( bt ) {
case tok_exp_tag : {
EXP e = DEREF_exp ( tok_exp_value ( btok ) ) ;
PUSH_exp ( e, token_exp_stack ) ;
if ( at == bt ) {
e = DEREF_exp ( tok_exp_value ( atok ) ) ;
} else {
e = NULL_exp ;
}
COPY_exp ( tok_exp_value ( btok ), e ) ;
break ;
}
case tok_nat_tag :
case tok_snat_tag : {
NAT n = DEREF_nat ( tok_nat_etc_value ( btok ) ) ;
PUSH_nat ( n, token_nat_stack ) ;
if ( at == bt ) {
n = DEREF_nat ( tok_nat_etc_value ( atok ) ) ;
} else {
n = NULL_nat ;
}
COPY_nat ( tok_nat_etc_value ( btok ), n ) ;
break ;
}
case tok_stmt_tag : {
EXP e = DEREF_exp ( tok_stmt_value ( btok ) ) ;
PUSH_exp ( e, token_stmt_stack ) ;
if ( at == bt ) {
e = DEREF_exp ( tok_stmt_value ( atok ) ) ;
} else {
e = NULL_exp ;
}
COPY_exp ( tok_stmt_value ( btok ), e ) ;
break ;
}
case tok_member_tag : {
OFFSET off = DEREF_off ( tok_member_value ( btok ) ) ;
PUSH_off ( off, token_mem_stack ) ;
if ( at == bt ) {
off = DEREF_off ( tok_member_value ( atok ) ) ;
} else {
off = NULL_off ;
}
COPY_off ( tok_member_value ( btok ), off ) ;
break ;
}
case tok_type_tag : {
TYPE t = DEREF_type ( tok_type_value ( btok ) ) ;
PUSH_type ( t, token_type_stack ) ;
if ( at == bt ) {
t = DEREF_type ( tok_type_value ( atok ) ) ;
} else {
t = NULL_type ;
}
COPY_type ( tok_type_value ( btok ), t ) ;
break ;
}
case tok_class_tag : {
IDENTIFIER cid = DEREF_id ( tok_class_value ( btok ) ) ;
PUSH_id ( cid, token_class_stack ) ;
if ( at == bt ) {
cid = DEREF_id ( tok_class_value ( atok ) ) ;
} else {
cid = NULL_id ;
}
COPY_id ( tok_class_value ( btok ), cid ) ;
break ;
}
default : {
/* Procedure arguments not allowed */
break ;
}
}
/* Allow definition of parameter */
ds = DEREF_dspec ( id_storage ( bid ) ) ;
if ( ds & dspec_pure ) {
ds &= ~dspec_pure ;
COPY_dspec ( id_storage ( bid ), ds ) ;
depth = 0 ;
}
}
bids = TAIL_list ( bids ) ;
}
in_proc_token++ ;
return ( depth ) ;
}
/*
RESTORE TOKEN ARGUMENT VALUES
This routine restores the argument values for the token parameters
pids by popping them from the stacks above. The pure field of the
tokens is set if depth is 0.
*/
void restore_token_args
PROTO_N ( ( pids, depth ) )
PROTO_T ( LIST ( IDENTIFIER ) pids X int depth )
{
LIST ( IDENTIFIER ) bids = pids ;
if ( !IS_NULL_list ( bids ) ) {
IDENTIFIER bid = DEREF_id ( HEAD_list ( bids ) ) ;
bids = TAIL_list ( bids ) ;
if ( !IS_NULL_list ( bids ) ) {
restore_token_args ( bids, depth ) ;
in_proc_token++ ;
}
if ( !IS_NULL_id ( bid ) && IS_id_token ( bid ) ) {
TOKEN btok = DEREF_tok ( id_token_sort ( bid ) ) ;
unsigned bt = TAG_tok ( btok ) ;
switch ( bt ) {
case tok_exp_tag : {
EXP e ;
POP_exp ( e, token_exp_stack ) ;
COPY_exp ( tok_exp_value ( btok ), e ) ;
break ;
}
case tok_nat_tag :
case tok_snat_tag : {
NAT n ;
POP_nat ( n, token_nat_stack ) ;
COPY_nat ( tok_nat_etc_value ( btok ), n ) ;
break ;
}
case tok_stmt_tag : {
EXP e ;
POP_exp ( e, token_stmt_stack ) ;
COPY_exp ( tok_stmt_value ( btok ), e ) ;
break ;
}
case tok_member_tag : {
OFFSET off ;
POP_off ( off, token_mem_stack ) ;
COPY_off ( tok_member_value ( btok ), off ) ;
break ;
}
case tok_type_tag : {
TYPE t ;
POP_type ( t, token_type_stack ) ;
COPY_type ( tok_type_value ( btok ), t ) ;
break ;
}
case tok_class_tag : {
IDENTIFIER cid ;
POP_id ( cid, token_class_stack ) ;
COPY_id ( tok_class_value ( btok ), cid ) ;
break ;
}
default : {
/* Procedure arguments not allowed */
break ;
}
}
if ( depth == 0 ) {
/* Can't define parameter at outer level */
DECL_SPEC ds = DEREF_dspec ( id_storage ( bid ) ) ;
ds |= dspec_pure ;
COPY_dspec ( id_storage ( bid ), ds ) ;
}
}
}
in_proc_token-- ;
return ;
}
/*
MERGE TOKEN ARGUMENT VALUES
This routine merges the argument values for the token parameters
pids with the values popped off the stacks above. It returns true
if the merge was successful. The pure field of the tokens is set
if depth is 0.
*/
int merge_token_args
PROTO_N ( ( pids, depth, qual ) )
PROTO_T ( LIST ( IDENTIFIER ) pids X int depth X int qual )
{
int ok = 1 ;
LIST ( IDENTIFIER ) bids = pids ;
if ( !IS_NULL_list ( bids ) ) {
IDENTIFIER bid = DEREF_id ( HEAD_list ( bids ) ) ;
bids = TAIL_list ( bids ) ;
if ( !IS_NULL_list ( bids ) ) {
ok = merge_token_args ( bids, depth, qual ) ;
in_proc_token++ ;
}
if ( !IS_NULL_id ( bid ) && IS_id_token ( bid ) ) {
TOKEN btok = DEREF_tok ( id_token_sort ( bid ) ) ;
unsigned bt = TAG_tok ( btok ) ;
switch ( bt ) {
case tok_exp_tag : {
EXP e ;
POP_exp ( e, token_exp_stack ) ;
if ( !IS_NULL_exp ( e ) ) {
if ( !define_exp_token ( bid, e, 1 ) ) ok = 0 ;
}
break ;
}
case tok_nat_tag :
case tok_snat_tag : {
NAT n ;
POP_nat ( n, token_nat_stack ) ;
if ( !IS_NULL_nat ( n ) ) {
if ( !define_nat_token ( bid, n ) ) ok = 0 ;
}
break ;
}
case tok_stmt_tag : {
EXP e ;
POP_exp ( e, token_stmt_stack ) ;
if ( !IS_NULL_exp ( e ) ) {
if ( !define_exp_token ( bid, e, 1 ) ) ok = 0 ;
}
break ;
}
case tok_member_tag : {
OFFSET off ;
POP_off ( off, token_mem_stack ) ;
if ( !IS_NULL_off ( off ) ) {
TYPE t = DEREF_type ( tok_member_type ( btok ) ) ;
if ( !define_mem_token ( bid, off, t, 0 ) ) ok = 0 ;
}
break ;
}
case tok_type_tag : {
TYPE t ;
POP_type ( t, token_type_stack ) ;
if ( !IS_NULL_type ( t ) ) {
if ( !define_type_token ( bid, t, qual ) ) ok = 0 ;
}
break ;
}
case tok_class_tag : {
IDENTIFIER cid ;
POP_id ( cid, token_class_stack ) ;
if ( !IS_NULL_id ( cid ) ) {
if ( !define_templ_token ( bid, cid ) ) ok = 0 ;
}
break ;
}
default : {
/* Procedure arguments not allowed */
break ;
}
}
if ( depth == 0 ) {
/* Can't define parameter at outer level */
DECL_SPEC ds = DEREF_dspec ( id_storage ( bid ) ) ;
ds |= dspec_pure ;
COPY_dspec ( id_storage ( bid ), ds ) ;
}
}
}
in_proc_token-- ;
return ( ok ) ;
}
/*
HAS A TOKEN BEEN BOUND?
This routine checks whether a value has been bound to the token tok.
If def is true then a dummy value is constructed for unbound values.
*/
int is_bound_tok
PROTO_N ( ( tok, def ) )
PROTO_T ( TOKEN tok X int def )
{
int bound = 1 ;
if ( !IS_NULL_tok ( tok ) ) {
switch ( TAG_tok ( tok ) ) {
case tok_exp_tag : {
/* Expression tokens */
EXP e = DEREF_exp ( tok_exp_value ( tok ) ) ;
if ( IS_NULL_exp ( e ) || EQ_exp ( e, redef_exp ) ) {
if ( def ) {
TYPE t = DEREF_type ( tok_exp_type ( tok ) ) ;
MAKE_exp_value ( t, e ) ;
COPY_exp ( tok_exp_value ( tok ), e ) ;
}
bound = 0 ;
}
break ;
}
case tok_nat_tag :
case tok_snat_tag : {
/* Integer constant tokens */
NAT n = DEREF_nat ( tok_nat_etc_value ( tok ) ) ;
if ( IS_NULL_nat ( n ) || EQ_nat ( n, redef_nat ) ) {
if ( def ) {
n = small_nat [1] ;
COPY_nat ( tok_nat_etc_value ( tok ), n ) ;
}
bound = 0 ;
}
break ;
}
case tok_stmt_tag : {
/* Statement tokens */
EXP e = DEREF_exp ( tok_stmt_value ( tok ) ) ;
if ( IS_NULL_exp ( e ) || EQ_exp ( e, redef_exp ) ) {
if ( def ) {
MAKE_exp_value ( type_void, e ) ;
COPY_exp ( tok_stmt_value ( tok ), e ) ;
}
bound = 0 ;
}
break ;
}
case tok_member_tag : {
/* Member tokens */
OFFSET off = DEREF_off ( tok_member_value ( tok ) ) ;
if ( IS_NULL_off ( off ) || EQ_off ( off, redef_off ) ) {
if ( def ) {
TYPE t = DEREF_type ( tok_member_type ( tok ) ) ;
MAKE_off_zero ( t, off ) ;
COPY_off ( tok_member_value ( tok ), off ) ;
}
bound = 0 ;
}
break ;
}
case tok_type_tag : {
/* Type tokens */
TYPE t = DEREF_type ( tok_type_value ( tok ) ) ;
if ( IS_NULL_type ( t ) || EQ_type ( t, redef_type ) ) {
if ( def ) {
t = type_error ;
COPY_type ( tok_type_value ( tok ), t ) ;
}
bound = 0 ;
}
break ;
}
case tok_class_tag : {
/* Template class tokens */
IDENTIFIER cid = DEREF_id ( tok_class_value ( tok ) ) ;
if ( IS_NULL_id ( cid ) || EQ_id ( cid, redef_id ) ) {
if ( def ) {
HASHID nm = KEYWORD ( lex_zzzz ) ;
cid = DEREF_id ( hashid_id ( nm ) ) ;
COPY_id ( tok_class_value ( tok ), cid ) ;
}
bound = 0 ;
}
break ;
}
}
}
return ( bound ) ;
}
/*
CONSTRUCT A LIST OF TOKEN ARGUMENTS
This routine constructs a list of token arguments for the token id
from the token parameters pids. Any errors arising from undefined
parameters are added to err.
*/
LIST ( TOKEN ) make_token_args
PROTO_N ( ( id, pids, err ) )
PROTO_T ( IDENTIFIER id X LIST ( IDENTIFIER ) pids X ERROR *err )
{
LIST ( TOKEN ) args = NULL_list ( TOKEN ) ;
while ( !IS_NULL_list ( pids ) ) {
IDENTIFIER pid = DEREF_id ( HEAD_list ( pids ) ) ;
if ( !IS_NULL_id ( pid ) && IS_id_token ( pid ) ) {
TOKEN tok = DEREF_tok ( id_token_sort ( pid ) ) ;
if ( !is_bound_tok ( tok, 1 ) ) {
/* Token parameter not defined */
if ( IS_id_token ( id ) ) {
add_error ( err, ERR_token_arg_undef ( pid, id ) ) ;
} else {
add_error ( err, ERR_temp_deduct_undef ( pid, id ) ) ;
}
}
tok = expand_sort ( tok, 2, 1 ) ;
CONS_tok ( tok, args, args ) ;
}
pids = TAIL_list ( pids ) ;
}
args = REVERSE_list ( args ) ;
return ( args ) ;
}
/*
SKIP TOKEN ARGUMENTS
This routine skips a set of token arguments for the token id. It is
entered with the current token pointing to the token name preceding
the initial open bracket.
*/
PPTOKEN *skip_token_args
PROTO_N ( ( id ) )
PROTO_T ( IDENTIFIER id )
{
PPTOKEN *q ;
LOCATION loc ;
int brackets = 0 ;
PPTOKEN *p = crt_token ;
loc = crt_loc ;
for ( ; ; ) {
int t = expand_preproc ( EXPAND_AHEAD ) ;
if ( t == lex_open_Hround ) {
brackets++ ;
} else if ( t == lex_close_Hround ) {
if ( --brackets == 0 ) break ;
} else if ( t == lex_eof ) {
HASHID nm = DEREF_hashid ( id_name ( id ) ) ;
report ( loc, ERR_cpp_replace_arg_eof ( nm ) ) ;
break ;
}
}
q = p->next ;
snip_tokens ( q, crt_token ) ;
crt_token = p ;
return ( q ) ;
}
/*
PARSE A SET OF TOKEN ARGUMENTS
This routine parses the preprocessing tokens p as a list of arguments
for the procedure token id.
*/
static LIST ( TOKEN ) parse_token_args
PROTO_N ( ( id, p ) )
PROTO_T ( IDENTIFIER id X PPTOKEN *p )
{
int t ;
int d = 0 ;
int ok = 1 ;
PARSE_STATE st ;
unsigned m = 0 ;
int started = 0 ;
LIST ( TOKEN ) args ;
ERROR err = NULL_err ;
TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
LIST ( IDENTIFIER ) pids = DEREF_list ( tok_proc_pids ( tok ) ) ;
LIST ( IDENTIFIER ) bids = DEREF_list ( tok_proc_bids ( tok ) ) ;
unsigned n = LENGTH_list ( pids ) ;
/* Initialise parser */
save_state ( &st, 1 ) ;
init_parser ( p ) ;
ADVANCE_LEXER ;
t = crt_lex_token ;
if ( t == lex_open_Hround || t == lex_open_Htemplate ) {
ADVANCE_LEXER ;
}
if ( IS_NULL_list ( pids ) ) {
/* Empty parameter list */
t = crt_lex_token ;
if ( t == lex_close_Hround || t == lex_close_Htemplate ) {
ADVANCE_LEXER ;
}
} else {
/* Non-empty parameter list */
while ( !IS_NULL_list ( pids ) ) {
IDENTIFIER pid = DEREF_id ( HEAD_list ( pids ) ) ;
if ( !IS_NULL_id ( pid ) ) {
TYPE mt = NULL_type ;
t = crt_lex_token ;
if ( t == lex_close_Hround || t == lex_close_Htemplate ) {
ADVANCE_LEXER ;
break ;
}
if ( started ) {
/* Each argument deduction is (nearly) independent */
mt = expand_member_type ( pid ) ;
d = save_token_args ( bids, NULL_list ( TOKEN ) ) ;
}
if ( !parse_token ( pid, mt, 1, 0, bids ) ) ok = 0 ;
if ( started ) {
/* Combine argument deductions */
IGNORE merge_token_args ( bids, d, 2 ) ;
}
started = 1 ;
if ( have_syntax_error ) {
ok = 0 ;
break ;
}
} else {
ok = 0 ;
break ;
}
m++ ;
t = crt_lex_token ;
if ( t == lex_close_Hround || t == lex_close_Htemplate ) {
ADVANCE_LEXER ;
break ;
}
pids = TAIL_list ( pids ) ;
if ( !IS_NULL_list ( pids ) ) {
if ( t == lex_comma ) {
ADVANCE_LEXER ;
} else {
report ( crt_loc, ERR_lex_expect ( lex_comma ) ) ;
}
}
}
}
/* Check for end of arguments */
if ( ok ) {
t = crt_lex_token ;
if ( t == lex_comma ) {
m = n + 1 ;
} else if ( t != lex_eof ) {
ERROR err2 = ERR_lex_parse ( crt_token ) ;
report ( crt_loc, err2 ) ;
ok = 0 ;
}
if ( ok && m != n ) {
HASHID nm = DEREF_hashid ( id_name ( id ) ) ;
ERROR err2 = ERR_cpp_replace_arg_number ( nm, m, m, n ) ;
report ( crt_loc, err2 ) ;
}
IGNORE check_value ( OPT_VAL_macro_args, ( ulong ) m ) ;
}
/* Restore state */
restore_state ( &st ) ;
p = restore_parser () ;
free_tok_list ( p ) ;
/* Construct token arguments */
args = make_token_args ( id, bids, &err ) ;
if ( !IS_NULL_err ( err ) ) {
if ( ok ) {
report ( crt_loc, err ) ;
} else {
destroy_error ( err, 1 ) ;
}
}
return ( args ) ;
}
/*
PARSE AN EXPRESSION TOKEN
This routine applies the expression procedure token id to the
arguments given by the preprocessing tokens p.
*/
EXP parse_exp_token
PROTO_N ( ( id, p ) )
PROTO_T ( IDENTIFIER id X PPTOKEN *p )
{
EXP e ;
LIST ( TOKEN ) args ;
TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
LIST ( IDENTIFIER ) bids = DEREF_list ( tok_proc_bids ( tok ) ) ;
int d = save_token_args ( bids, NULL_list ( TOKEN ) ) ;
args = parse_token_args ( id, p ) ;
e = apply_exp_token ( id, args, 2 ) ;
restore_token_args ( bids, d ) ;
return ( e ) ;
}
/*
PARSE A TYPE TOKEN
This routine applies the type procedure token id to the arguments
given by the preprocessing tokens p.
*/
TYPE parse_type_token
PROTO_N ( ( id, p ) )
PROTO_T ( IDENTIFIER id X PPTOKEN *p )
{
TYPE t ;
if ( IS_id_token ( id ) ) {
/* Type token */
LIST ( TOKEN ) args ;
TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
LIST ( IDENTIFIER ) bids = DEREF_list ( tok_proc_bids ( tok ) ) ;
int d = save_token_args ( bids, NULL_list ( TOKEN ) ) ;
args = parse_token_args ( id, p ) ;
t = apply_type_token ( id, args, NULL_id ) ;
restore_token_args ( bids, d ) ;
} else {
/* Typedef template */
t = parse_typedef_templ ( id, p ) ;
}
return ( t ) ;
}
/*
PARSE A MEMBER TOKEN
This routine applies the member procedure token id to the arguments
given by the preprocessing tokens p.
*/
OFFSET parse_mem_token
PROTO_N ( ( id, p ) )
PROTO_T ( IDENTIFIER id X PPTOKEN *p )
{
OFFSET off ;
LIST ( TOKEN ) args ;
TOKEN tok = DEREF_tok ( id_token_sort ( id ) ) ;
LIST ( IDENTIFIER ) bids = DEREF_list ( tok_proc_bids ( tok ) ) ;
int d = save_token_args ( bids, NULL_list ( TOKEN ) ) ;
args = parse_token_args ( id, p ) ;
off = apply_mem_token ( id, args ) ;
restore_token_args ( bids, d ) ;
return ( off ) ;
}
/*
DEFINE A TOKEN USING A MACRO
This routine defines the tokenised object id by means of the macro
mid. It returns true if this is possible.
*/
int define_token_macro
PROTO_N ( ( id, mid ) )
PROTO_T ( IDENTIFIER id X IDENTIFIER mid )
{
DECL_SPEC fds = DEREF_dspec ( id_storage ( id ) ) ;
IDENTIFIER tid = find_token ( id ) ;
if ( IS_id_token ( tid ) ) {
int fn = 1 ;
PPTOKEN *p ;
PPTOKEN *r ;
LOCATION loc ;
PARSE_STATE st ;
STACK ( EXP ) tries ;
LIST ( IDENTIFIER ) pids ;
LIST ( TYPE ) ex = univ_type_set ;
TOKEN tok = DEREF_tok ( id_token_sort ( tid ) ) ;
DECL_SPEC ds = DEREF_dspec ( id_storage ( tid ) ) ;
/* Find token definition */
if ( IS_id_obj_macro ( mid ) ) {
switch ( TAG_tok ( tok ) ) {
case tok_func_tag : {
/* Function tokens read as identifiers */
IGNORE find_func_token ( id, ( unsigned ) UINT_MAX ) ;
COPY_dspec ( id_storage ( id ), ( fds & ~dspec_token ) ) ;
fn = 0 ;
break ;
}
case tok_templ_tag :
case tok_proc_tag : {
/* Can't have procedure tokens */
report ( preproc_loc, ERR_token_def_args ( id ) ) ;
return ( 1 ) ;
}
}
p = DEREF_pptok ( id_obj_macro_defn ( mid ) ) ;
} else {
unsigned n = DEREF_unsigned ( id_func_macro_no_params ( mid ) ) ;
switch ( TAG_tok ( tok ) ) {
case tok_func_tag : {
/* Find function token with n parameters */
TYPE t = DEREF_type ( tok_func_type ( tok ) ) ;
tid = find_func_token ( id, n ) ;
if ( IS_NULL_id ( tid ) ) {
report ( preproc_loc, ERR_token_def_args ( id ) ) ;
return ( 1 ) ;
}
tok = DEREF_tok ( id_token_sort ( tid ) ) ;
tok = func_proc_token ( tok ) ;
id = DEREF_id ( id_token_alt ( tid ) ) ;
fds = DEREF_dspec ( id_storage ( id ) ) ;
COPY_dspec ( id_storage ( id ), ( fds & ~dspec_token ) ) ;
ex = DEREF_list ( type_func_except ( t ) ) ;
break ;
}
case tok_proc_tag : {
/* Procedure tokens */
pids = DEREF_list ( tok_proc_pids ( tok ) ) ;
if ( LENGTH_list ( pids ) != n ) {
report ( preproc_loc, ERR_token_def_args ( id ) ) ;
return ( 1 ) ;
}
break ;
}
default : {
/* Can't have simple tokens */
report ( preproc_loc, ERR_token_def_args ( id ) ) ;
return ( 1 ) ;
}
}
p = DEREF_pptok ( id_func_macro_defn ( mid ) ) ;
}
/* Expand token definition */
p = expand_tok_list ( p ) ;
r = new_pptok () ;
r->tok = lex_newline ;
r->next = NULL ;
if ( p == NULL ) {
p = r ;
} else {
PPTOKEN *q = p ;
while ( q->next ) q = q->next ;
q->next = r ;
}
/* Allow for procedure tokens */
if ( IS_tok_proc ( tok ) ) {
NAMESPACE ns ;
PPTOKEN *q = p ;
pids = DEREF_list ( tok_proc_pids ( tok ) ) ;
while ( q != NULL ) {
if ( q->tok == lex_macro_Harg ) {
unsigned long pn = q->pp_data.par.no - 1 ;
LIST ( IDENTIFIER ) qids = pids ;
while ( pn && !IS_NULL_list ( qids ) ) {
qids = TAIL_list ( qids ) ;
pn-- ;
}
if ( !IS_NULL_list ( qids ) ) {
IDENTIFIER qid = DEREF_id ( HEAD_list ( qids ) ) ;
if ( !IS_NULL_id ( qid ) ) {
HASHID qnm = DEREF_hashid ( id_name ( qid ) ) ;
q->tok = lex_identifier ;
q->pp_data.id.hash = qnm ;
q->pp_data.id.use = qid ;
}
}
}
q = q->next ;
}
pids = DEREF_list ( tok_proc_bids ( tok ) ) ;
while ( !IS_NULL_list ( pids ) ) {
IDENTIFIER pid = DEREF_id ( HEAD_list ( pids ) ) ;
if ( !IS_NULL_id ( pid ) ) {
DECL_SPEC pds = DEREF_dspec ( id_storage ( pid ) ) ;
pds |= dspec_pure ;
COPY_dspec ( id_storage ( pid ), pds ) ;
}
pids = TAIL_list ( pids ) ;
}
ns = DEREF_nspace ( tok_proc_pars ( tok ) ) ;
add_namespace ( ns ) ;
}
/* Parse token */
loc = crt_loc ;
bad_crt_loc++ ;
crt_loc = preproc_loc ;
tries = crt_try_blocks ;
start_try_check ( ex ) ;
save_state ( &st, 0 ) ;
init_parser ( p ) ;
ADVANCE_LEXER ;
pids = NULL_list ( IDENTIFIER ) ;
IGNORE parse_token ( tid, NULL_type, fn, 1, pids ) ;
if ( !have_syntax_error && crt_lex_token != lex_newline ) {
ERROR err = ERR_lex_parse ( crt_token ) ;
report ( crt_loc, err ) ;
}
if ( ds & dspec_pure ) {
report ( preproc_loc, ERR_token_def_not ( id ) ) ;
} else {
if ( do_dump ) dump_declare ( id, &crt_loc, 1 ) ;
}
restore_state ( &st ) ;
p = restore_parser () ;
free_tok_list ( p ) ;
IGNORE end_try_check ( id, NULL_exp ) ;
crt_try_blocks = tries ;
crt_loc = loc ;
bad_crt_loc-- ;
/* Allow for procedure tokens */
if ( IS_tok_proc ( tok ) ) {
remove_namespace () ;
pids = DEREF_list ( tok_proc_bids ( tok ) ) ;
while ( !IS_NULL_list ( pids ) ) {
IDENTIFIER pid = DEREF_id ( HEAD_list ( pids ) ) ;
if ( !IS_NULL_id ( pid ) ) {
DECL_SPEC pds = DEREF_dspec ( id_storage ( pid ) ) ;
pds &= ~dspec_pure ;
COPY_dspec ( id_storage ( pid ), pds ) ;
}
pids = TAIL_list ( pids ) ;
}
}
COPY_dspec ( id_storage ( id ), fds ) ;
return ( 1 ) ;
}
return ( 0 ) ;
}
/*
DEFINE A MEMBER TOKEN
This routine is used to define the tokenised member id of t by the
list of immediately following preprocessing tokens. This is used
to implement the '#pragma TenDRA member definition' command.
*/
int define_mem_macro
PROTO_N ( ( id, t ) )
PROTO_T ( IDENTIFIER id X TYPE t )
{
IDENTIFIER tid = tok_member ( id, t, 0 ) ;
if ( !IS_NULL_id ( tid ) ) {
id = tid ;
tid = find_token ( tid ) ;
if ( !IS_NULL_id ( tid ) && IS_id_token ( tid ) ) {
TOKEN tok = DEREF_tok ( id_token_sort ( tid ) ) ;
if ( IS_tok_member ( tok ) ) {
int def ;
LOCATION loc ;
DECL_SPEC ds = DEREF_dspec ( id_storage ( tid ) ) ;
LIST ( IDENTIFIER ) pids = NULL_list ( IDENTIFIER ) ;
bad_crt_loc++ ;
loc = crt_loc ;
crt_loc = preproc_loc ;
def = parse_token ( tid, NULL_type, 1, 1, pids ) ;
if ( ds & dspec_pure ) {
report ( preproc_loc, ERR_token_def_not ( id ) ) ;
} else {
if ( do_dump ) dump_declare ( id, &crt_loc, 1 ) ;
}
crt_loc = loc ;
bad_crt_loc-- ;
return ( def ) ;
}
}
report ( preproc_loc, ERR_token_undecl ( id ) ) ;
}
if ( in_preproc_dir ) IGNORE skip_to_end () ;
return ( 0 ) ;
}
/*
PENDING TOKEN FOR IDENTIFIER UNIFICATION
The normal unification routine is called immediately after the
declaration of an object. However for 'const' objects it is more
useful to postpone the unification until after the initialisation.
*/
IDENTIFIER unify_id_pending = NULL_id ;
/*
UNIFY TWO IDENTIFIERS
This routine is called whenever an identifier id hides an identifier
pid from the same namespace. Normally this is a redeclaration error
which will have been caught by the declaration routines, however if
pid is a token identifier it may be a token definition. The routine
returns true if this is the case.
*/
int unify_id
PROTO_N ( ( pid, id, def ) )
PROTO_T ( IDENTIFIER pid X IDENTIFIER id X int def )
{
int ok = 0 ;
IDENTIFIER tid = DEREF_id ( id_token_alt ( pid ) ) ;
if ( IS_id_token ( tid ) ) {
/* Previous definition was a token */
TOKEN tok = DEREF_tok ( id_token_sort ( tid ) ) ;
switch ( TAG_tok ( tok ) ) {
case tok_exp_tag :
case tok_nat_tag :
case tok_snat_tag : {
/* Expression tokens */
EXP e ;
int expl = 0 ;
switch ( TAG_id ( id ) ) {
case id_variable_tag : {
#if LANGUAGE_CPP
TYPE t = DEREF_type ( id_variable_type ( id ) ) ;
CV_SPEC cv = DEREF_cv ( type_qual ( t ) ) ;
if ( cv == ( cv_lvalue | cv_const ) ) {
/* Allow for const objects */
e = DEREF_exp ( id_variable_init ( id ) ) ;
if ( IS_NULL_exp ( e ) ) {
if ( IS_NULL_id ( unify_id_pending ) ) {
unify_id_pending = pid ;
return ( 1 ) ;
}
}
}
#endif
unify_id_pending = NULL_id ;
goto variable_label ;
}
case id_enumerator_tag : {
expl = 1 ;
goto variable_label ;
}
variable_label :
case id_parameter_tag :
case id_stat_member_tag : {
e = make_id_exp ( id ) ;
if ( define_exp_token ( tid, e, expl ) ) {
LOCATION loc ;
DEREF_loc ( id_loc ( id ), loc ) ;
COPY_loc ( id_loc ( tid ), loc ) ;
}
ok = 1 ;
break ;
}
}
break ;
}
}
if ( ok ) {
/* Set alternate look-up for token */
HASHID nm = DEREF_hashid ( id_name ( tid ) ) ;
MEMBER mem = search_member ( token_namespace, nm, 0 ) ;
if ( !IS_NULL_member ( mem ) ) {
COPY_id ( member_alt ( mem ), id ) ;
}
}
}
if ( ok ) {
/* Token definition */
DECL_SPEC ds = DEREF_dspec ( id_storage ( tid ) ) ;
if ( ds & dspec_pure ) {
report ( crt_loc, ERR_token_def_not ( pid ) ) ;
} else {
if ( do_dump ) dump_declare ( pid, &crt_loc, 1 ) ;
}
} else {
/* Illegal redeclaration */
if ( def ) id = pid ;
report ( crt_loc, ERR_basic_odr_diff ( id, id_loc ( id ) ) ) ;
}
return ( ok ) ;
}