/*
* Copyright (c) 2002, The Tendra Project
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice unmodified, this list of conditions, and the following
* disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
* IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
* OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
* IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
* NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
* THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*
* 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.
*
* $TenDRA: tendra/src/producers/common/construct/tokdef.c,v 1.7 2004/08/14 15:15:36 bp Exp $
*/
#include "config.h"
#include "producer.h"
#include
#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(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(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()
{
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(IDENTIFIER id, 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(IDENTIFIER id, EXP e, 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(IDENTIFIER id, 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(BASE_TYPE bt, unsigned ca, 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(IDENTIFIER id, TYPE t, 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(IDENTIFIER id, 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(IDENTIFIER id, OFFSET off, TYPE t, 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(IDENTIFIER id, 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(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(IDENTIFIER id, TYPE t, int fn, int mac, 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(IDENTIFIER id, 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(LIST (IDENTIFIER) pids, 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(LIST (IDENTIFIER) pids, 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(LIST (IDENTIFIER) pids, int depth, 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(TOKEN tok, 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(IDENTIFIER id, LIST (IDENTIFIER) pids, 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(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(IDENTIFIER id, 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(IDENTIFIER id, 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(IDENTIFIER id, 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(IDENTIFIER id, 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(IDENTIFIER id, 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(IDENTIFIER id, 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(IDENTIFIER pid, IDENTIFIER id, 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);
}