/*
 * Copyright (c) 2002, The Tendra Project <http://www.ten15.org/>
 * 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
 *
 *    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/parse/pragma.c,v 1.8 2005/10/22 13:47:15 stefanf Exp $
 */


#include "config.h"
#include "producer.h"
#include "c_types.h"
#include "hashid_ops.h"
#include "id_ops.h"
#include "tok_ops.h"
#include "error.h"
#include "catalog.h"
#include "option.h"
#include "buffer.h"
#include "char.h"
#include "declare.h"
#include "dump.h"
#include "file.h"
#include "lex.h"
#include "hash.h"
#include "macro.h"
#include "parse.h"
#include "pragma.h"
#include "predict.h"
#include "preproc.h"
#include "psyntax.h"
#include "redeclare.h"
#include "statement.h"
#include "symbols.h"
#include "tok.h"
#include "token.h"
#include "ustring.h"
#include "variable.h"


/*
 *    CHECK THAT PRAGMA SYNTAX AND MAIN SYNTAX ARE IN STEP
 *
 *    By including both psyntax.h and syntax.h, the compiler will check
 *    that the lex_* macros defined in each are consistent.  Note that
 *    because the #pragma syntax is the same for both C and C++, this
 *    also checks the consistency of the C and C++ syntaxes.  This is only
 *    done in development mode.
 */

#ifdef DEBUG
#include "syntax.h"
#endif


/*
 *    READ A PREPROCESSING TOKEN
 *
 *    This routine reads the next preprocessing token from the input file.
 */

static PPTOKEN *
get_token(void)
{
	PPTOKEN *p = new_pptok ();
	int t = read_token ();
	update_column ();
	p->tok = t;
	p->pp_space = WHITE_SPACE;
	p->next = NULL;
	if (t <= LAST_COMPLEX_TOKEN) token_parts (t, p);
	return (p);
}


/*
 *    FIND A KEYWORD LEXICAL TOKEN NUMBER
 *
 *    This routine finds the lexical token corresponding to the identifier id.
 *    If id does not represent an underlying keyword then an error is reported
 *    and lex_identifier is returned.
 */

int
find_keyword(IDENTIFIER id)
{
	HASHID nm = DEREF_hashid (id_name (id));
	int t = find_hashid (nm);
	if (t == lex_identifier) {
		report (preproc_loc, ERR_pragma_keyword_bad (nm));
	}
	return (t);
}


/*
 *    DEFINE A KEYWORD
 *
 *    This routine defines id to be a keyword with lexical token number t.
 *    Certain language extensions are implemented by tokens disguised as
 *    keywords.
 */

void
define_keyword(IDENTIFIER id, int t)
{
	switch (t) {
	case lex_identifier : {
		break;
	}
	case lex_representation : {
		TOKEN tok = make_sort ("ZZZ", 1);
		id = make_token_decl (tok, 0, id, id);
		token_interface (id, lex_no_Hdef);
		COPY_int (tok_proc_key (tok), t);
		break;
	}
	case lex_typeof : {
		TOKEN tok = make_sort ("SE", 1);
		id = make_token_decl (tok, 0, id, id);
		token_interface (id, lex_no_Hdef);
		COPY_int (tok_proc_key (tok), t);
		break;
	}
	default : {
		HASHID nm = DEREF_hashid (id_name (id));
		IGNORE make_keyword (nm, t, NULL_id);
		break;
	}
	}
	return;
}


/*
 *    UNDEFINE A KEYWORD
 *
 *    This routine undefines the keyword id.
 */

void
undef_keyword(IDENTIFIER id)
{
	unsigned tag;
	HASHID nm = DEREF_hashid (id_name (id));
	PTR (IDENTIFIER) ptr = hashid_id (nm);
	do {
		IDENTIFIER pid = DEREF_id (ptr);
		tag = TAG_id (pid);
		switch (tag) {
		case id_keyword_tag :
		case id_iso_keyword_tag :
		case id_reserved_tag : {
			/* Undefine a keyword */
			if (do_keyword) dump_undefine (pid, &preproc_loc, 1);
			pid = DEREF_id (id_alias (pid));
			COPY_id (ptr, pid);
			COPY_id (hashid_cache (nm), NULL_id);
			return;
		}
		}
		ptr = id_alias (pid);
	} while (tag != id_dummy_tag);
	return;
}


/*
 *    RESCAN A PRAGMA STATEMENT
 *
 *    The routine read_tendra replaces all identifier tokens within a '#pragma'
 *    command by their corresponding underlying keywords.  This routine restores
 *    these keywords, except that given by s, to identifiers.
 */

void
rescan_pragma(int s)
{
	PPTOKEN *p;
	for (p = crt_token; p != NULL; p = p->next) {
		int t = p->tok;
		if (t >= FIRST_KEYWORD && t <= LAST_KEYWORD && t != s) {
			p->tok = lex_identifier;
		}
	}
	return;
}


/*
 *    SET A TOKEN TO A KEYWORD
 *
 *    This routine sets the preprocessing token p to the keyword corresponding
 *    to the lexical token number t.
 */

static void
set_token(PPTOKEN *p, int t)
{
	HASHID nm = KEYWORD (t);
	p->tok = t;
	p->pp_data.id.hash = nm;
	p->pp_data.id.use = DEREF_id (hashid_id (nm));
	return;
}


/*
 *    PATCH A PRAGMA STATEMENT
 *
 *    This routine is used by the preprocessor to preserve a '#pragma'
 *    statement.  The arguments are as in parse_pragma.
 */

static void
patch_pragma(PPTOKEN *p, int tendra)
{
	p = clean_tok_list (p);
	switch (p->tok) {
	case lex_interface : {
		int t = crt_interface;
		if (t == lex_ignore && tendra) t = lex_reject;
		set_token (p, t);
		break;
	}
	case lex_member : {
		if (!tendra) {
			if (p->next->tok == lex_definition) {
				set_token (p, lex_define_Hcap);
				set_token (p->next, lex_member_Hcap);
			}
		}
		break;
	}
	case lex_promoted : {
		if (!tendra) set_token (p, lex_promote);
		break;
	}
	case lex_reject : {
		if (!tendra) set_token (p, lex_ignore);
		break;
	}
	}
	patch_preproc_dir (p);
	if (tendra) {
		p = patch_tokens (tendra);
		set_token (p, lex_tendra);
		if (tendra == 2) p->next->tok = lex_plus_Hplus;
	}
	return;
}


/*
 *    PARSE A PRAGMA STATEMENT
 *
 *    This routine parses the '#pragma' statement given by the preprocessing
 *    tokens p.  tendra is 1 for '#pragma TenDRA' statements, 2 for '#pragma
 *    TenDRA++' statements, and 0 otherwise.
 */

static int
parse_pragma(PPTOKEN *p, int tendra)
{
	int nt;
	PPTOKEN *pt;
	PARSE_STATE s;
	int pp = preproc_only;
	int tok = lex_ignore_token;
	
	/* Parsing action */
	new_linkage = crt_linkage;
	save_state (&s, 0);
	init_parser (p);
	crt_loc = preproc_loc;
	crt_line_changed = 1;
	ADVANCE_LEXER;
	if (pp) {
		parse_preproc (&tok);
		if (tok != lex_ignore_token) {
			tok = lex_ignore_token;
			have_syntax_error = 1;
		}
	} else {
		parse_tendra (&tok);
	}
	nt = crt_lex_token;
	pt = crt_token;
	p = restore_parser ();
	
	/* Check for end of input */
	switch (tok) {
	case lex_set :
	case lex_unused : {
		/* Patch inset pragma statements */
		PPTOKEN *q = clean_tok_list (p);
		PPTOKEN *r = new_pptok ();
		p = q;
		p->tok = tok;
		while (q->tok != lex_newline) q = q->next;
		q->tok = lex_inset_Hend;
		r->tok = lex_newline;
		r->next = q->next;
		q->next = r;
		patch_preproc_dir (p);
		tok = lex_inset_Hstart;
		p = NULL;
		break;
	}
	default : {
		/* Should have reached the end of the line */
		if (nt != lex_newline && !have_syntax_error) {
			ERROR err = ERR_lex_parse (pt);
			err = concat_error (err, ERR_cpp_end (lex_pragma));
			report (preproc_loc, err);
		}
		break;
	}
	}
	
	/* Preprocessing action */
	if (pp) {
		patch_pragma (p, tendra);
		tok = lex_hash_Hpragma;
	} else {
		free_tok_list (p);
	}
	restore_state (&s);
	crt_linkage = new_linkage;
	return (tok);
}


/*
 *    SKIP TO NEXT COLON
 *
 *    This routine scans along the list of preprocessing tokens p until it
 *    finds the first colon.  It then returns the following token.  The null
 *    token is returned if there is no colon in p.
 */

static PPTOKEN *
skip_to_colon(PPTOKEN *p)
{
	while (p) {
		PPTOKEN *q = p->next;
		if (p->tok == lex_colon) return (q);
		p = q;
	}
	return (NULL);
}


/*
 *    MARK A TOKEN PARAMETER
 *
 *    This routine marks the TDF token parameter given by the preprocessing
 *    tokens p.  This consists of an optional 'TAG' followed by an identifier,
 *    which is optional if n is false.  Macro expansion of this identifier
 *    is inhibited.  Macro is true if the identifier is declared in the
 *    token namespace.
 */

static PPTOKEN *
mark_tdf_param(PPTOKEN *p, int n, int macro)
{
	if (p && p->tok == lex_identifier) {
		int t = find_hashid (p->pp_data.id.hash);
		if (t == lex_tag_Hcap) {
			if (p->next && p->next->tok == lex_identifier) {
				/* Have 'TAG id' */
				p->tok = t;
				p = p->next;
				p->pp_data.id.use = NULL_id;
			} else {
				/* Have 'TAG' */
				if (n == 0) {
					/* Interpret as 'TAG' */
					p->tok = t;
				} else {
					/* Interpret as 'id' where id = TAG */
					p->pp_data.id.use = NULL_id;
				}
			}
		} else {
			/* Have 'id' */
			if (macro && preproc_only) {
				/* Mark macro names when preprocessing */
				HASHID nm = p->pp_data.id.hash;
				unsigned c = check_macro (nm, 0);
				IDENTIFIER id = underlying_id (p->pp_data.id.use);
				DECL_SPEC ds = DEREF_dspec (id_storage (id));
				ds |= dspec_token;
				COPY_dspec (id_storage (id), ds);
				if (c == PP_TRUE) {
					/* Token previously defined as macro */
					PPTOKEN *q;
					token_macro = DEREF_id (hashid_id (nm));
					IGNORE patch_cond (lex_hash_Hop, lex_define);
					q = patch_tokens (2);
					q->tok = lex_builtin_Hfile;
					q->next->tok = lex_hash_Hop;
				}
			}
			p->pp_data.id.use = NULL_id;
		}
		return (p->next);
	}
	if (n) return (NULL);
	return (p);
}


/*
 *    MARK A TOKEN PROGRAM PARAMETER
 *
 *    This routine marks the TDF token program parameter given by the
 *    preprocessing tokens p.
 */

static PPTOKEN *
mark_prog_param(PPTOKEN *p)
{
	if (p && p->tok == lex_identifier) {
		int t = find_hashid (p->pp_data.id.hash);
		switch (t) {
		case lex_exp_Hcap :
		case lex_nat_Hcap :
		case lex_int_Hcap :
		case lex_stmt_Hcap :
		case lex_proc_Hcap : {
			/* Have the form 'EXP id' etc */
			p->tok = t;
			p = p->next;
			if (p) p = p->next;
			return (p);
		}
		case lex_type_Hcap : {
			/* Have the form 'TYPE t' */
			int depth = 0;
			p->tok = t;
			while (p) {
				/* Step over type */
				switch (p->tok) {
				case lex_open_Hround :
				case lex_open_Hsquare_H1 :
				case lex_open_Hsquare_H2 : {
					depth++;
					break;
				}
				case lex_close_Hround :
				case lex_close_Hsquare_H1 :
				case lex_close_Hsquare_H2 : {
					if (depth > 0) depth--;
					break;
				}
				case lex_comma : {
					if (depth == 0) return (p);
					break;
				}
				case lex_close_Hbrace_H1 :
				case lex_close_Hbrace_H2 : {
					return (p);
				}
				}
				p = p->next;
			}
			break;
		}
		case lex_member_Hcap : {
			/* Have the form 'MEMBER t : id' */
			p->tok = t;
			p = skip_to_colon (p->next);
			if (p) p = p->next;
			return (p);
		}
		}
	}
	return (NULL);
}


/*
 *    MARK A PRAGMA TOKEN STATEMENT
 *
 *    The macro expansion of '#pragma token' statements is rather complex.
 *    The token syntax skeleton is not subject to macro expansion, while
 *    any types etc. involved in the specification are.  This routine marks
 *    the skeleton keywords in the list of preprocessing tokens p, returning
 *    the token immediately following the token specification.  It also sets
 *    macro to true if the declared token lies in the macro namespace.
 */

static PPTOKEN *
mark_tdf_token(PPTOKEN *p, int *macro)
{
	if (p == NULL) return (NULL);
	if (p->tok == lex_identifier) {
		int t = find_hashid (p->pp_data.id.hash);
		switch (t) {
			
		case lex_exp_Hcap : {
			/* Expression token specifiers */
			*macro = 1;
			p->tok = t;
			p = p->next;
			if (p->tok == lex_identifier) {
				/* Check for lvalue or rvalue qualifier */
				t = find_hashid (p->pp_data.id.hash);
				if (t == lex_lvalue || t == lex_rvalue ||
					t == lex_const) {
					p->tok = t;
				}
				p = p->next;
			}
			if (p->tok == lex_colon) {
				/* Step over type name */
				p = skip_to_colon (p->next);
			}
			return (p);
		}
			
		case lex_func_Hcap : {
			/* Function token specifiers */
			*macro = 1;
			p->tok = t;
			p = skip_to_colon (p->next);
			return (p);
		}
			
		case lex_member_Hcap : {
			/* Member token specifiers */
			p->tok = t;
			p = p->next;
			if (p->tok == lex_identifier) {
				/* Check for access specifier */
				t = find_hashid (p->pp_data.id.hash);
				if (t == lex_public || t == lex_protected ||
					t == lex_private) {
					p->tok = t;
					p = p->next;
				}
			}
			p = skip_to_colon (p);
			p = skip_to_colon (p);
			return (p);
		}
			
		case lex_proc_Hcap : {
			/* Procedure token specifiers */
			*macro = 1;
			p->tok = t;
			p = p->next;
			if (p == NULL) return (NULL);
			t = p->tok;
			if (t == lex_open_Hbrace_H1 || t == lex_open_Hbrace_H2) {
				/* General procedure parameters */
				p = p->next;
				for (;;) {
					if (p == NULL) break;
					t = p->tok;
					if (t == lex_or_H1) {
						p = p->next;
						break;
					}
					p = mark_tdf_token (p, macro);
					p = mark_tdf_param (p, 1, 0);
					if (p == NULL) break;
					if (p->tok == lex_comma) p = p->next;
				}
				for (;;) {
					if (p == NULL) break;
					t = p->tok;
					if (t == lex_close_Hbrace_H1 ||
						t == lex_close_Hbrace_H2) {
						p = p->next;
						break;
					}
					p = mark_prog_param (p);
					if (p == NULL) break;
					if (p->tok == lex_comma) p = p->next;
				}
			} else if (t == lex_open_Hround) {
				/* Simple procedure parameters */
				p = p->next;
				for (;;) {
					if (p == NULL) break;
					t = p->tok;
					if (t == lex_close_Hround) {
						p = p->next;
						break;
					}
					p = mark_tdf_token (p, macro);
					p = mark_tdf_param (p, 0, 0);
					if (p == NULL) break;
					if (p->tok == lex_comma) p = p->next;
				}
			}
			p = mark_tdf_token (p, macro);
			return (p);
		}
			
		case lex_variety_Hcap : {
			/* Integral type token specifiers */
			p->tok = t;
			p = p->next;
			if (p->tok == lex_identifier) {
				/* Check for signed or unsigned qualifier */
				t = find_hashid (p->pp_data.id.hash);
				if (t == lex_signed || t == lex_unsigned) {
					p->tok = t;
					p = p->next;
				}
			}
			return (p);
		}
			
		case lex_nat_Hcap :
		case lex_int_Hcap :
		case lex_stmt_Hcap : {
			/* Simple token specifiers */
			*macro = 1;
			p->tok = t;
			return (p->next);
		}
			
		case lex_arith_Hcap :
		case lex_class_Hcap :
		case lex_float_Hcap :
		case lex_scalar_Hcap :
		case lex_struct_Hcap :
		case lex_type_Hcap :
		case lex_union_Hcap : {
			/* Type token specifiers */
			p->tok = t;
			return (p->next);
		}
		}
	}
	return (p->next);
}


/*
 *    READ AN EXTERNAL TOKEN NAME
 *
 *    This routine processes an external token name.  This consists of a
 *    hash symbol, pointed to by p, followed a list of preprocessing
 *    tokens.  Note that the result is an extended identifier, unless it
 *    is a simple identifier.
 */

static PPTOKEN *
quote_token_name(PPTOKEN *p)
{
	PPTOKEN *q = p->next;
	if (q != NULL) {
		/* All following tokens are quoted */
		string s;
		unsigned long sp = q->pp_space;
		IGNORE quote_tok_list (q, 0, char_quote);
		free_tok_list (q);
		q = new_pptok ();
		q->pp_space = sp;
		q->next = NULL;
		s = token_buff.start;
		if (ustrseq (s, "-")) {
			/* Special form '-' */
			q->tok = lex_minus;
		} else {
			/* Create an identifier */
			unsigned long h = hash (s);
			token_hashid = lookup_name (s, h, 1, lex_unknown);
			q->tok = lex_identifier;
			token_parts (lex_identifier, q);
		}
		p->next = q;
		p = q;
	}
	return (p);
}


/*
 *    READ A PRAGMA TOKEN STATEMENT
 *
 *    This routine processes a '#pragma token' statement.  p gives the first
 *    preprocessing token (i.e. 'token').  tendra is as in parse_pragma.
 */

static int
read_tdf_token(PPTOKEN *p, int tendra)
{
	/* Read and macro expand the rest of the line */
	int t;
	PPTOKEN *q = p;
	while (q->next) q = q->next;
	if (q->tok != lex_newline) {
		int macro = 0;
		PPTOKEN *r = read_line (lex_ignore_token, lex_ignore_token);
		if (r) r->pp_space = WHITE_SPACE;
		q->next = r;
		r = mark_tdf_token (r, &macro);
		r = mark_tdf_param (r, 1, macro);
		while (r) {
			/* Find token name */
			t = r->tok;
			if (t == lex_hash_H1 || t == lex_hash_H2) {
				q = quote_token_name (r);
				break;
			}
			q = r;
			r = r->next;
		}
		
		/* Add newline token */
		while (q->next) q = q->next;
		q->next = new_pptok ();
		q->next->tok = lex_newline;
		q->next->next = NULL;
	}
	q = expand_tok_list (p);
	free_tok_list (p);
	
	/* Parse the line */
	in_token_decl = 1;
	decl_loc = preproc_loc;
	t = parse_pragma (q, tendra);
	in_token_decl = 0;
	return (t);
}


/*
 *    READ A PRAGMA TENDRA STATEMENT
 *
 *    This routine processes a '#pragma TenDRA' statement, returning the
 *    corresponding lexical token.  One or two tokens from the line will
 *    have already been read into p.  tendra is as in parse_pragma.
 */

static int
read_tendra(PPTOKEN *p, int tendra)
{
	/* Read and macro expand the rest of the line */
	PPTOKEN *q = p;
	while (q->next) q = q->next;
	if (q->tok != lex_newline) {
		PPTOKEN *r = read_line (lex_ignore_token, lex_newline);
		if (r) r->pp_space = WHITE_SPACE;
		q->next = r;
	}
	q = expand_tok_list (p);
	free_tok_list (p);
	p = q;
	
	/* Replace any identifiers by keywords */
	for (q = p; q != NULL; q = q->next) {
		int t = q->tok;
		if (t == lex_identifier) {
			t = find_hashid (q->pp_data.id.hash);
			q->tok = t;
		}
	}
	
	/* Parse the line */
	return (parse_pragma (p, tendra));
}


/*
 *    READ A PRAGMA INTERFACE STATEMENT
 *
 *    This routine processes a '#pragma interface' statement, returning the
 *    corresponding lexical token.  One or two tokens from the line will
 *    have already been read into p.  tendra is as in parse_pragma.
 */

static int
read_interface(PPTOKEN *p, int tendra)
{
	/* Read and macro expand the rest of the line */
	int tok;
	int nl = 0;
	PPTOKEN *q = p;
	PPTOKEN *r = p;
	while (q->next) q = q->next;
	if (q->tok != lex_newline) {
		PPTOKEN *s = read_line (lex_ignore_token, lex_ignore_token);
		if (s) s->pp_space = WHITE_SPACE;
		q->next = s;
		nl = 1;
	}
	for (q = p; q != NULL; q = q->next) {
		/* Suppress expansion of 'TAG' */
		int t = q->tok;
		if (t == lex_identifier) {
			t = find_hashid (q->pp_data.id.hash);
			if (t == lex_tag_Hcap) q->tok = t;
		} else if (t == lex_hash_H1 || t == lex_hash_H2) {
			r = quote_token_name (q);
			break;
		}
		r = q;
	}
	
	/* Add newline token */
	if (nl) {
		while (r->next) r = r->next;
		r->next = new_pptok ();
		r->next->tok = lex_newline;
		r->next->next = NULL;
	}
	
	/* Parse the line */
	tok = parse_pragma (p, tendra);
	return (tok);
}


/*
 *    PROCESS A NON-TENDRA PRAGMA STATEMENT
 *
 *    This routine processes a '#pragma' statement in which there is no
 *    TenDRA keyword, or such a keyword is optional.  The argument p gives
 *    the first preprocessing token of the statement, while tendra is as
 *    in parse_pragma.  The corresponding lexical token value is returned
 *    if the statement is recognised, otherwise lex_unknown is returned.
 *    The non-TenDRA and TenDRA forms may differ as follows:
 *
 *	token				TenDRA token
 *	extend interface		TenDRA extend
 *	implement interface		TenDRA implement
 *	define				TenDRA define
 *	no_def				TenDRA no_def
 *	ignore				TenDRA reject
 *	interface			TenDRA interface
 *	promote				TenDRA promoted
 *	compute promote			TenDRA compute promote (?)
 *	integer literal			TenDRA integer literal
 *	external volatile		TenDRA external volatile
 *	DEFINE MEMBER			TenDRA member definition
 */

static int
read_non_tendra(PPTOKEN *p, int tendra)
{
	if (p->tok == lex_identifier) {
		int t = find_hashid (p->pp_data.id.hash);
		switch (t) {
			
		case lex_token : {
			/* Token syntax */
			p->tok = t;
			return (read_tdf_token (p, tendra));
		}
			
		case lex_extend :
		case lex_implement : {
			/* Interface inclusion */
			int pp;
			if (!tendra) {
				/* Need 'interface' for non-TenDRA form */
				PPTOKEN *q = get_token ();
				p->next = q;
				if (q->tok == lex_identifier) {
					int s = find_hashid (q->pp_data.id.hash);
					if (s != lex_interface) break;
				}
			}
			pp = read_include (1, lex_pragma);
			if (pp == lex_included) {
				/* Update current interface flag */
				if (t == lex_implement) {
					crt_interface = lex_define;
				} else {
					if (crt_interface != lex_no_Hdef) {
						crt_interface = lex_ignore;
					}
				}
			}
			return (pp);
		}
			
		case lex_define :
		case lex_no_Hdef :
		case lex_interface : {
			/* Interface listing */
			p->tok = t;
			return (read_interface (p, tendra));
		}
			
		case lex_reject : {
			/* Interface listing (TenDRA form) */
			if (tendra) {
				p->tok = t;
				return (read_interface (p, tendra));
			}
			break;
		}
			
		case lex_ignore : {
			/* Interface listing (non-TenDRA form) */
			if (!tendra) {
				p->tok = lex_reject;
				return (read_interface (p, tendra));
			}
			break;
		}
			
		case lex_undef : {
			/* Token undefining */
			PPTOKEN *q = get_token ();
			p->next = q;
			if (q->tok == lex_identifier) {
				int s = find_hashid (q->pp_data.id.hash);
				if (s == lex_token) {
					p->tok = t;
					q->tok = s;
					return (read_interface (p, tendra));
				}
			}
			break;
		}
			
		case lex_promote : {
			/* Promotion specification (non-TenDRA form) */
			if (!tendra) {
				set_token (p, lex_promoted);
				return (read_tendra (p, tendra));
			}
			break;
		}
			
		case lex_promoted : {
			/* Promotion specification (TenDRA form) */
			if (tendra) {
				set_token (p, lex_promoted);
				return (read_tendra (p, tendra));
			}
			break;
		}
			
		case lex_compute : {
			/* Computed promotion specification */
			PPTOKEN *q = get_token ();
			p->next = q;
			if (q->tok == lex_identifier) {
				int s = find_hashid (q->pp_data.id.hash);
				if (s == lex_promote) {
					set_token (p, t);
					set_token (q, s);
					return (read_tendra (p, tendra));
				}
			}
			break;
		}
			
		case lex_integer : {
			/* Integer literal specification */
			PPTOKEN *q = get_token ();
			p->next = q;
			if (q->tok == lex_identifier) {
				int s = find_hashid (q->pp_data.id.hash);
				if (s == lex_lit) {
					set_token (p, t);
					set_token (q, s);
					return (read_tendra (p, tendra));
				}
			}
			break;
		}
			
		case lex_define_Hcap : {
			/* Member definition (non-TenDRA form) */
			if (!tendra) {
				PPTOKEN *q = get_token ();
				p->next = q;
				if (q->tok == lex_identifier) {
					int s = find_hashid (q->pp_data.id.hash);
					if (s == lex_member_Hcap) {
						set_token (p, lex_member);
						set_token (q, lex_definition);
						return (read_tendra (p, tendra));
					}
				}
			}
			break;
		}
			
		case lex_member : {
			/* Member definition (TenDRA form) */
			if (tendra) {
				PPTOKEN *q = get_token ();
				p->next = q;
				if (q->tok == lex_identifier) {
					int s = find_hashid (q->pp_data.id.hash);
					if (s == lex_definition) {
						set_token (p, lex_member);
						set_token (q, lex_definition);
						return (read_tendra (p, tendra));
					}
				}
			}
			break;
		}
			
		case lex_accept : {
			/* Conversion tokens (non-TenDRA form) */
			if (!tendra) {
				PPTOKEN *q = get_token ();
				p->next = q;
				if (q->tok == lex_ellipsis) {
					return (read_tendra (p, tendra));
				}
				if (q->tok == lex_identifier) {
					int s = find_hashid (q->pp_data.id.hash);
					if (s == lex_conversion) {
						return (read_tendra (p, tendra));
					}
				}
			}
			break;
		}
			
		case lex_external : {
			/* External volatility (non-TenDRA form) */
			if (!tendra) {
				PPTOKEN *q = get_token ();
				p->next = q;
				if (q->tok == lex_identifier) {
					int s = find_hashid (q->pp_data.id.hash);
					if (s == lex_volatile) {
						return (read_tendra (p, tendra));
					}
				}
			}
			break;
		}
			
		case lex_preserve : {
			/* Preserve statics (non-TenDRA form) */
			return (read_tendra (p, tendra));
		}
		}
	}
	return (lex_unknown);
}


/*
 *    PROCESS A PRAGMA STATEMENT
 *
 *    This routine analyses a '#pragma' statement, returning the corresponding
 *    lexical token.  It is called from read_preproc_dir (q.v.) immediately
 *    after the '#pragma' directive has been identified.  It is not called for
 *    skipped '#pragma' directives.  The calling routine will skip to the end
 *    of the preprocessing directive if necessary.
 */

int
read_pragma(void)
{
	int t;
	PPTOKEN *p = get_token ();
	if (p->tok == lex_identifier) {
		t = find_hashid (p->pp_data.id.hash);
		switch (t) {
			
		case lex_tendra : {
			/* Deal with '#pragma TenDRA' */
			int tendra = 1;
			p->next = free_tokens;
			free_tokens = p;
			p = get_token ();
			if (p->tok == lex_plus_Hplus) {
				/* Allow for TenDRA++ */
#if LANGUAGE_CPP
				p->next = free_tokens;
				free_tokens = p;
				p = get_token ();
				tendra = 2;
#else
				return (lex_ignore_token);
#endif
			}
			
			/* Allow for optional TenDRA pragmas */
			t = read_non_tendra (p, tendra);
			if (t != lex_unknown) return (t);
			
			/* Deal with TenDRA pragmas */
			t = read_tendra (p, tendra);
			return (t);
		}
			
		case lex_ident : {
			/* Deal with '#pragma ident' */
			if (!option (OPT_ppdir_ident_ignore)) {
				read_ident (lex_pragma);
			}
			return (lex_ignore_token);
		}
			
		case lex_weak : {
			/* Deal with '#pragma weak' */
			if (!option (OPT_ppdir_weak_ignore)) {
				read_weak (lex_pragma);
			}
			return (lex_ignore_token);
		}
		}
	}
	
	/* Deal with non-TenDRA pragmas */
	t = read_non_tendra (p, 0);
	if (t != lex_unknown) return (t);
	
	/* Report unknown pragmas */
	free_tok_list (p);
	report (preproc_loc, ERR_cpp_pragma_unknown (lex_pragma));
	return (lex_ignore_token);
}


/*
 *    ANALYSE A LINT COMMENT
 *
 *    This routine analyses the comment built up in token_buff for lint
 *    format comments.  These are interpreted locally.  This can go slightly
 *    wrong with look-ahead, in which case the more structured keyword
 *    approach should be used.  Other fairly standard lint comments include
 *    VARARGS, LINTLIBRARY, CONSTANTCONDITION (CONSTCOND), EMPTY, LINTED,
 *    PROTOLIB, PRINTFLIKE and SCANFLIKE.
 */

int
lint_comment(void)
{
	string t;
	size_t sz;
	character c;
	string s = token_buff.start;
	while (c = *s, is_white_char ((unsigned long) c)) {
		/* Step over initial white space */
		s++;
	}
	t = s;
	while (c = *s, is_alpha_char ((unsigned long) c)) {
		/* Scan to end of identifier */
		s++;
	}
	
	/* Check identifier */
	sz = (size_t) (s - t);
	switch (sz) {
	case 8 : {
		if (strncmp (strlit (t), "ARGSUSED", sz) == 0) {
			/* Indicate unused variables */
			suppress_variable = 1;
		} else if (strncmp (strlit (t), "FALLTHRU", sz) == 0) {
			/* Suppress fall through errors */
			suppress_fall = 1;
		}
		break;
	}
	case 10 : {
		if (strncmp (strlit (t), "NOTREACHED", sz) == 0) {
			/* Suppress unreached code errors */
			unreached_last = 1;
		}
		break;
	}
	case 11 : {
		if (strncmp (strlit (t), "FALLTHROUGH", sz) == 0) {
			/* Suppress fall through errors */
			suppress_fall = 1;
		}
		break;
	}
	}
	
	/* Rest of comment is ignored */
	return (lex_ignore_token);
}


/*
 *    HANDLE THE PRAGMA OPERATOR
 *
 *    This function checks if an occurrence of the identifier _Pragma is a
 *    valid application of the _Pragma operator.  For that the next three
 *    tokens after _Pragma need to be a left parenthesis, a string literal
 *    and a right parenthesis.  Escaped " and \ characters in the string are
 *    unquoted.  A _Pragma operator is equivalent to a #pragma preprocessing
 *    directive followed by the string content.  The function returns 1 if a
 *    valid application of _Pragma was found and 0 otherwise.
 */

int
operator_pragma(void)
{
	int t;
	PPTOKEN *this_tok = crt_token;

	t = expand_token (EXPAND_PRAGMA);
	if (t == lex_open_Hround) {
		t = expand_token (EXPAND_PRAGMA);
		if (t == lex_string_Hlit || t == lex_wstring_Hlit) {
			string sb = crt_token->pp_data.str.start;
			string se = crt_token->pp_data.str.end;
			t = expand_token (EXPAND_PRAGMA);
			if (t == lex_close_Hround) {
				/* Write 'pragma <string>\n\n' into internal_buff. */
				BUFFER *bf = &internal_buff;
				bfputs (bf, ustrlit ("pragma "));
				/* Unquote \\ and \". */
				while (sb != se) {
					if (sb[0] == '\\' && (sb[1] == '\\' || sb[1] == '"')) {
						bfputc (bf, sb[1]);
						sb += 2;
					} else
						bfputc (bf, *sb++);
				}
				/* Two newlines are needed here.  One is consumed by
				 * parse_pragma() and without the second one we complain
				 * that the file doesn't end in a newline. */
				bfputs (bf, ustrlit ("\n\n"));
				bf->end = bf->posn;
				bf->posn = bf->start;

				if (setup_pragma ()) {
					read_preproc_dir (1, lex_ignore_token);
				}
				return (1);
			}
		}
	}

	/* Make _Pragma the current token */
	crt_token = this_tok;
	return (0);
}


syntax highlighted by Code2HTML, v. 0.9.1