/*
 * 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, 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/parse/literal.c,v 1.17 2005/10/26 21:24:36 stefanf Exp $
 */


#include "config.h"
#include "producer.h"

#include <limits.h>

#include "cstring.h"
#include "fmm.h"
#include "msgcat.h"

#include "c_types.h"
#include "exp_ops.h"
#include "flt_ops.h"
#include "id_ops.h"
#include "itype_ops.h"
#include "nat_ops.h"
#include "str_ops.h"
#include "type_ops.h"
#include "error.h"
#include "catalog.h"
#include "option.h"
#include "basetype.h"
#include "cast.h"
#include "char.h"
#include "chktype.h"
#include "constant.h"
#include "convert.h"
#include "dump.h"
#include "exception.h"
#include "expression.h"
#include "hash.h"
#include "inttype.h"
#include "lex.h"
#include "literal.h"
#include "preproc.h"
#include "syntax.h"
#include "tok.h"
#include "token.h"
#include "ustring.h"


/*
 *    SPECIAL TABLE VALUES
 *
 *    These macros are used in the tables of digits and escape sequences
 *    to indicate special values.
 */

#define NONE			0xff
#define OCTE			0xfe
#define HEXE			0xfd
#define UNI4			0xfc
#define UNI8			0xfb


/*
 *    TABLE OF DIGITS
 *
 *    This table gives the mapping of characters to digits.  The default
 *    table assumes the ASCII character set, for other codesets it needs
 *    to be rewritten.  The valid digits are 0-9, A-Z (which evaluate to
 *    10-35) and a-z (which evaluate to 10-35).  Invalid digits are
 *    indicated by NONE.
 */

unsigned char digit_values [NO_CHAR + 1] = {
#define CHAR_DATA(A, B, C, D)	(B),
#include "char.h"
#undef CHAR_DATA
	NONE		/* dummy */
};


/*
 *    TABLE OF ESCAPE SEQUENCES
 *
 *    This table gives the mapping of characters to escape sequences.  The
 *    default table assumes the ASCII character set, for other codesets it
 *    needs to be rewritten.  The valid escape sequences are \', \", \?,
 *    \\, \a, \b, \f, \n, \r, \t and \v.  Octal escape sequences are
 *    indicated by OCTE, hexadecimal escape sequences by HEXE, universal
 *    character names by UNI4 or UNI8, and illegal escape sequences by
 *    NONE.
 */

unsigned char escape_sequences [NO_CHAR + 1] = {
#define CHAR_DATA(A, B, C, D)	(C),
#include "char.h"
#undef CHAR_DATA
	NONE		/* dummy */
};


/*
 *    SET AN ESCAPE SEQUENCE
 *
 *    This routine sets the character escape value for the character
 *    literal expression a to be the character literal b, or an illegal
 *    escape if b is the null expression.
 */

void
set_escape(EXP a, EXP b)
{
	int c = get_char_value (a);
	int e = NONE;
	if (!IS_NULL_exp (b)) {
		e = get_char_value (b);
		if (e == char_illegal) e = NONE;
	}
	if (c >= 0 && c < NO_CHAR) {
		escape_sequences [c] = (unsigned char) e;
	}
	return;
}


/*
 *    CHECK A STRING OF DIGITS
 *
 *    This routine scans the string s for valid digits for the given base.
 *    It returns a pointer to the first character which is not a valid
 *    digit.
 */

static string
check_digits(string s, unsigned base)
{
	unsigned b;
	character c;
	while (c = *s, c != 0) {
#if FS_EXTENDED_CHAR
		if (IS_EXTENDED (c)) break;
#endif
		b = (unsigned) digit_values [c];
		if (b >= base) break;
		s++;
	}
	return (s);
}


/*
 *    EVALUATE A STRING OF DIGITS
 *
 *    This routine evaluates the string of digits starting with s and
 *    ending with t using the given base (which will be at most 16).  It
 *    is assumed that all of these digits are in the correct range.
 */

static NAT
eval_digits(string s, string t, unsigned base)
{
	NAT n;
	int m = 0;
	string r = s;
	unsigned long v = 0;
	unsigned long b = (unsigned long) base;
	while (r != t && m < 8) {
		/* Evaluate first few digits */
		unsigned long d = (unsigned long) digit_values [*r];
		v = b * v + d;
		m++;
		r++;
	}
	n = make_nat_value (v);
	while (r != t) {
		/* Evaluate further digits */
		unsigned d = (unsigned) digit_values [*r];
		n = make_nat_literal (n, base, d);
		r++;
	}
	return (n);
}


/*
 *    EVALUATE A STRING OF DIGITS
 *
 *    This routine is the same as eval_digits except that it assumes that
 *    the result fits inside an unsigned long, and reports an error
 *    otherwise.
 */

static unsigned long
eval_char_digits(string s, string t, unsigned base)
{
	string r;
	int overflow = 0;
	unsigned long n = 0;
	unsigned long b = (unsigned long) base;
	for (r = s; r != t; r++) {
		unsigned long m = n;
		n = b * n + (unsigned long) digit_values [*r];
		if (n < m) overflow = 1;
	}
	if (overflow) report (crt_loc, ERR_lex_ccon_large ());
	return (n);
}


/*
 *    EVALUATE A LINE NUMBER
 *
 *    This routine evaluates the sequence of decimal digits s as a line
 *    number in a #line, or similar, preprocessing directive.  Any errors
 *    arising are indicated using err.  This is a bit pattern consisting
 *    of 2 if s is not a simple string of decimal digits, and 1 if its
 *    value exceeds the currently set limit.
 */

unsigned long
eval_line_digits(string s, unsigned *err)
{
	string r;
	unsigned e = 0;
	unsigned long n = 0;
	string t = check_digits (s, (unsigned) 10);
	if (*t) e = 2;
	for (r = s; r != t; r++) {
		int d = digit_values [*r];
		if (n > (ULONG_MAX - d) / 10) {
			e |= 1;
			break;
		}
		n = 10 * n + d;
	}
	if (n > option_value (OPT_VAL_hash_line_number))
		e |= 1;
	*err = e;
	return (n);
}


/*
 *    STRING HASH TABLE
 *
 *    This variable gives the hash table used in shared string literals.
 */

static STRING *string_hash_table = NULL;
#define HASH_STRING_SIZE	((unsigned long) 256)


/*
 *    STRING AND CHARACTER LITERAL TYPES
 *
 *    The type of a simple character literal is char in C++, but int in C.
 *    The variable type_char_lit is used to hold the appropriate result
 *    type.  Other string and character literals have fixed types, however
 *    for convenience variables are used to identify them.
 */

static TYPE type_char_lit;
static TYPE type_mchar_lit;
static TYPE type_wchar_lit;
static TYPE type_string_lit;
static TYPE type_wstring_lit;
CV_SPEC cv_string = cv_none;


/*
 *    SET THE CHARACTER LITERAL TYPE
 *
 *    This routine sets the type of a character literal to be t.  t must be
 *    an integral type.  Note that only the representation type is set to t,
 *    the semantic type is always char.
 */

void
set_char_lit(TYPE t)
{
	if (IS_type_integer (t)) {
		INT_TYPE r = DEREF_itype (type_integer_rep (t));
		INT_TYPE s = DEREF_itype (type_integer_rep (type_char));
		type_char_lit = make_itype (r, s);
	} else {
		report (preproc_loc, ERR_pragma_char_lit (t));
	}
	return;
}


/*
 *    TABLE OF INTEGER LITERAL SPECIFICATIONS
 *
 *    The type LITERAL_INFO is used to represent an item in an integer
 *    literal type specification.  The table int_lit_spec holds the
 *    specifications for the various combinations of base and suffix.
 */

typedef struct lit_info_tag {
	int tag;
	TYPE type;
	NAT bound;
	IDENTIFIER tok;
	int tok_no;
	int opt;
	struct lit_info_tag *next;
} LITERAL_INFO;

static LITERAL_INFO *int_lit_spec [BASE_NO] [SUFFIX_NO] = {
	{ NULL, NULL, NULL, NULL, NULL, NULL },
	{ NULL, NULL, NULL, NULL, NULL, NULL },
	{ NULL, NULL, NULL, NULL, NULL, NULL }
};

static LITERAL_INFO *crt_int_lit = NULL;
static LITERAL_INFO **ptr_int_lit = NULL;


/*
 *    TABLE OF BUILT-IN INTEGER LITERAL SPECIFICATIONS
 *
 *    This table gives the possible types and built-in tokens for the
 *    various base and suffix combinations.
 */

static struct {
	unsigned char type [6];
	int tok;
	LIST (TYPE) cases;
} int_lit_tok [BASE_NO] [SUFFIX_NO] = {
	{
		{ { 2, 0, 2, 2, 1, 1 }, TOK_lit_int, NULL_list (TYPE) },
		{ { 0, 2, 0, 2, 0, 1 }, TOK_lit_unsigned, NULL_list (TYPE) },
		{ { 0, 0, 2, 2, 1, 1 }, TOK_lit_long, NULL_list (TYPE) },
		{ { 0, 0, 0, 2, 0, 1 }, TOK_lit_ulong, NULL_list (TYPE) },
		{ { 0, 0, 0, 0, 2, 2 }, TOK_lit_llong, NULL_list (TYPE) },
		{ { 0, 0, 0, 0, 0, 2 }, TOK_lit_ullong, NULL_list (TYPE) }
	},
	{
		{ { 2, 2, 2, 2, 1, 1 }, TOK_lit_hex, NULL_list (TYPE) },
		{ { 0, 2, 0, 2, 0, 1 }, TOK_lit_unsigned, NULL_list (TYPE) },
		{ { 0, 0, 2, 2, 1, 1 }, TOK_lit_long, NULL_list (TYPE) },
		{ { 0, 0, 0, 2, 0, 1 }, TOK_lit_ulong, NULL_list (TYPE) },
		{ { 0, 0, 0, 0, 2, 2 }, TOK_lit_llong, NULL_list (TYPE) },
		{ { 0, 0, 0, 0, 0, 2 }, TOK_lit_ullong, NULL_list (TYPE) }
	},
	{
		{ { 2, 2, 2, 2, 1, 1 }, TOK_lit_hex, NULL_list (TYPE) },
		{ { 0, 2, 0, 2, 0, 1 }, TOK_lit_unsigned, NULL_list (TYPE) },
		{ { 0, 0, 2, 2, 1, 1 }, TOK_lit_long, NULL_list (TYPE) },
		{ { 0, 0, 0, 2, 0, 1 }, TOK_lit_ulong, NULL_list (TYPE) },
		{ { 0, 0, 0, 0, 2, 2 }, TOK_lit_llong, NULL_list (TYPE) },
		{ { 0, 0, 0, 0, 0, 2 }, TOK_lit_ullong, NULL_list (TYPE) }
	}
};


/*
 *    INITIALISE TABLE OF INTEGER LITERAL TYPES
 *
 *    This routine initialises the string and character literal types and
 *    the table int_lit_info.  The initial values for the table are given
 *    by the following lists of types:
 *
 *	decimal:	(int, long, unsigned long),
 *	octal/hex:	(int, unsigned, long, unsigned long),
 *	U suffix:	(unsigned, unsigned long),
 *	L suffix:	(long, unsigned long),
 *	UL suffix:	(unsigned long),
 *	LL suffix:	(long long, unsigned long long),
 *	ULL suffix:	(unsigned long long).
 *
 *    Each integer literal is checked against each type in the list
 *    indicated by the form of the literal.  If it fits into a type then
 *    that is the type of the literal.  If it does not fit into any type
 *    then an error is raised.  If whether it fits into a particular type
 *    is target dependent then a literal integer type, giving the literal
 *    value and a list of possible types, is constructed to express the
 *    result type.
 *
 *    The string and character types are:
 *
 *	character:		char,
 *	multi-character:	int,
 *	wide character:		wchar_t,
 *	string:			const char [n],
 *	wide string:		const wchar_t [n].
 *
 *    Variants are that characters have type int in C and that string
 *    literals are not const in pre-ISO C++ and C.
 */

void
init_literal(void)
{
	int b, s;
	BUILTIN_TYPE n;
	OPTION opt = option (OPT_int_overflow);
	ASSERT (!IS_NULL_type (type_char));

	/* String and character literal types */
	type_mchar_lit = type_sint;
	type_wchar_lit = type_wchar_t;
	type_string_lit = type_char;
	type_wstring_lit = type_wchar_t;
#if LANGUAGE_CPP
	set_char_lit (type_char);
	set_string_qual (cv_const);
#else
	set_char_lit (type_sint);
	set_string_qual (cv_none);
#endif

	/* Set up type lists */
	for (b = 0; b < BASE_NO; b++) {
		for (s = 0; s < SUFFIX_NO; s++) {
			LIST (TYPE) p = NULL_list (TYPE);
			begin_literal (b, s);
			for (n = 0; n < 6; n++) {
				if (int_lit_tok [b] [s].type [n] == 2) {
					TYPE t = type_builtin [ntype_sint + n];
					add_range_literal (NULL_exp, 1);
					add_type_literal (t);
					CONS_type (t, p, p);
				}
			}
			add_range_literal (NULL_exp, 0);
			add_token_literal (NULL_id, (unsigned) opt);
			p = REVERSE_list (p);
			int_lit_tok [b] [s].cases = uniq_type_set (p);
		}
	}

	/* Set up string hash table */
	if (string_hash_table == NULL) {
		unsigned long i;
		STRING *q = xmalloc_nof (STRING, HASH_STRING_SIZE);
		for (i = 0; i < HASH_STRING_SIZE; i++) q [i] = NULL_str;
		string_hash_table = q;
	}
	return;
}


/*
 *    SET THE CV-QUALIFIERS FOR A STRING LITERAL
 *
 *    This routine sets the string and wide string literal types to be
 *    cv-qualified.
 */

void
set_string_qual(CV_SPEC cv)
{
	type_string_lit = qualify_type (type_string_lit, cv, 0);
	type_wstring_lit = qualify_type (type_wstring_lit, cv, 0);
	cv_string = cv;
	return;
}


/*
 *    BEGIN A LITERAL SPECIFICATION DEFINITION
 *
 *    This routine is called to begin the specification of the integer
 *    literals of the given base and suffix.
 */

void
begin_literal(int base, int suff)
{
	LITERAL_INFO **p = &(int_lit_spec [base] [suff]);
	*p = NULL;
	ptr_int_lit = p;
	crt_int_lit = NULL;
	return;
}


/*
 *    ADD A BOUND TO A LITERAL SPECIFICATION
 *
 *    This routine is used to specify a bound in the current literal
 *    specification.  If n is 0 then the bound matches all values, if it
 *    is 1 then the bound matches all the values in the following type,
 *    and if it is 2 then the bound matches all values less than or equal
 *    to the integer literal expression e.
 */

void
add_range_literal(EXP e, int n)
{
	LITERAL_INFO *p = xmalloc (sizeof(*p));
	p->tag = n;
	if (!IS_NULL_exp (e) && IS_exp_int_lit (e)) {
		p->bound = DEREF_nat (exp_int_lit_nat (e));
	} else {
		p->bound = small_nat [0];
	}
	p->type = NULL_type;
	p->tok = NULL_id;
	p->tok_no = -1;
	p->opt = OPT_none;
	p->next = NULL;
	*ptr_int_lit = p;
	crt_int_lit = p;
	ptr_int_lit = &(p->next);
	return;
}


/*
 *    ADD A TYPE TO A LITERAL SPECIFICATION
 *
 *    This routine specifies the type t for all values under the current
 *    bound in the current literal specification.
 */

void
add_type_literal(TYPE t)
{
	NAT n;
	LITERAL_INFO *p = crt_int_lit;
	if (IS_type_integer (t)) {
		if (!is_arg_promote (t)) {
			/* Type should promote to itself */
			report (preproc_loc, ERR_pragma_lit_type (t));
			t = promote_type (t);
		}
	} else {
		/* Type should be integral */
		if (!IS_type_error (t)) {
			report (preproc_loc, ERR_pragma_lit_type (t));
		}
		t = type_ulong;
	}
	p->type = qualify_type (t, cv_none, 0);
	n = p->bound;
	if (p->tag == 2) {
		if (check_nat_range (t, n) != NAT_FIT) {
			/* Given bound should fit into type */
			report (preproc_loc, ERR_pragma_lit_range (n, t));
			n = max_type_value (t, 0);
		}
	} else {
		n = max_type_value (t, 0);
	}
	p->bound = n;
	return;
}


/*
 *    ADD A TOKEN TO A LITERAL SPECIFICATION
 *
 *    This routine specifies that the token id should be used to calculate
 *    the type for all values under the current bound in the current
 *    literal specification.  An error with severity sev is reported.
 */

void
add_token_literal(IDENTIFIER id, unsigned sev)
{
	int n = -1;
	LITERAL_INFO *p = crt_int_lit;
	if (!IS_NULL_id (id)) {
		id = resolve_token (id, "ZZ", 0);
		if (!IS_NULL_id (id)) n = builtin_token (id);
	}
	if (p->tag == 1) {
		report (preproc_loc, ERR_pragma_lit_question ());
		p->tag = 3;
	}
	p->tok = id;
	p->tok_no = n;
	switch (sev) {
	case OPTION_ON : p->opt = OPT_error; break;
	case OPTION_WARN : p->opt = OPT_warning; break;
	default : p->opt = OPT_none; break;
	}
	return;
}


/*
 *    FIND AN INTEGER LITERAL TYPE
 *
 *    This routine finds the type of the integer constant lit specified
 *    with base base and suffix suff.  num gives the text used to specify
 *    the constant for the purposes of error reporting.  fit is set to
 *    true if lit definitely fits into the result.
 */

TYPE
find_literal_type(NAT lit, int base, int suff, string num, int *fit)
{
	TYPE t;
	int tok;
	INT_TYPE it;
	int big = 0;
	int have_tok = 0;
	int opt = OPT_error;
	NAT n = small_nat [0];
	IDENTIFIER tid = NULL_id;
	LIST (TYPE) qt = NULL_list (TYPE);
	LITERAL_INFO *pt = int_lit_spec [base] [suff];

	/* Deal with calculated literals */
	switch (TAG_nat (lit)) {
	case nat_neg_tag : {
		lit = DEREF_nat (nat_neg_arg (lit));
		t = find_literal_type (lit, base, suff, num, fit);
		return (t);
	}
	case nat_token_tag : {
		t = type_sint;
		*fit = 1;
		return (t);
	}
	case nat_calc_tag : {
		EXP e = DEREF_exp (nat_calc_value (lit));
		t = DEREF_type (exp_type (e));
		*fit = 1;
		return (t);
	}
	}

	/* Deal with simple literals */
	while (pt != NULL) {
		int ch = 4;
		TYPE s = pt->type;
		switch (pt->tag) {
		case 0 : {
			TYPE r = s;
			if (IS_NULL_type (r)) r = type_ulong;
			ch = check_nat_range (r, lit);
			if (ch == NAT_FIT) *fit = 1;
			if (ch >= NAT_NEVERFIT_SIGNED) big = ch;
			if (big) n = max_type_value (NULL_type, 0);
			ch = big;
			break;
		}
		case 1 : {
			n = pt->bound;
			ch = check_nat_range (s, lit);
			if (ch == NAT_FIT) *fit = 1;
			break;
		}
		case 2 : {
			n = pt->bound;
			if (compare_nat (n, lit) >= 0) {
				if (!IS_NULL_type (s)) *fit = 1;
				ch = 0;
			}
			break;
		}
		}
		if (ch == NAT_FIT) {
			/* lit definitely fits into bound */
			if (!IS_NULL_type (s) && IS_NULL_list (qt)) {
				/* No previous fit */
				return (s);
			}
		}
		if (ch <= NAT_MAYFIT_UNSIGNED) {
			/* lit may fit into bound */
			if (!IS_NULL_type (s)) {
				if (have_tok == 0) {
					INT_TYPE is = DEREF_itype (type_integer_rep (s));
					LIST (TYPE) st = DEREF_list (itype_cases (is));
					qt = union_type_set (qt, st);
					if (ch == NAT_FIT) have_tok = 1;
				}
			} else {
				if (have_tok == 0 && !IS_NULL_id (pt->tok)) {
					DESTROY_list (qt, SIZE_type);
					tok = int_lit_tok [base] [suff].tok;
					if (pt->tok_no == tok) {
						qt = int_lit_tok [base] [suff].cases;
					} else if (suff < SUFFIX_LL) {
						qt = all_prom_types;
					} else {
						qt = all_llong_types;
					}
					have_tok = 2;
				}
				break;
			}
		}
		if (ch >= NAT_NEVERFIT_SIGNED) big = ch;
		pt = pt->next;
	}

	/* Tokenised result */
	if (have_tok != 2) {
		/* Find list of possible types */
		if (IS_NULL_list (qt)) {
			qt = int_lit_tok [base] [suff].cases;
		} else {
			qt = REVERSE_list (qt);
			qt = uniq_type_set (qt);
		}
	}
	if (pt) {
		/* Get token information from table */
		tid = pt->tok;
		opt = pt->opt;
	}
	if (num && !(*fit)) {
		/* Report error if necessary */
		ERROR err = ERR_lex_icon_large (num, n);
		err = set_severity (err, opt, 0);
		if (!IS_NULL_err (err)) report (crt_loc, err);
	}
	if (LENGTH_list (qt) == 1) {
		/* Only one possible case */
		t = DEREF_type (HEAD_list (qt));
		DESTROY_list (qt, SIZE_type);
		return (t);
	}
	tok = int_lit_tok [base] [suff].tok;
	MAKE_itype_literal (NULL_type, qt, lit, tok, base, suff, tid, it);
	t = promote_itype (it, it);
	return (t);
}


/*
 *    SHIFT A HEXADECIMAL STRING
 *
 *    This routine shifts the hexadecimal string s to the right by n bits.
 *    The value n must be less than 4.  The vacant bits at s' leftmost
 *    position are filled with shift_in.  If shift_out a null pointer, an
 *    additional character that holds the shifted out bits is added.
 *    Otherwise the bits are stored in *shift_out.
 */

static string
shift_hex_string(string s, unsigned n, unsigned shift_in, unsigned *shift_out)
{
	static const char hex_values[] = "0123456789abcdef";
	unsigned c, mask, v, x;
	string out, ret;

	ASSERT (n <= 3);

	if (n == 0) return ustring_copy (s);

	out = ret = ustring_alloc (ustrlen (s) + (shift_out != NULL ? 1 : 2));

	mask = (1u << n) - 1;
	c = shift_in;
	while ((v = digit_values[*s++]) < 16) {
		x = (v >> n) | c;
		c = (v & mask) << (4 - n);
		*out++ = hex_values[x];
	}
	if (shift_out != NULL) {
		*shift_out = c;
	} else {
		*out++ = hex_values[c];
	}
	*out++ = '\0';
	return ret;
}


/*
 *    ANALYSE AN INTEGER OR FLOATING LITERAL
 *
 *    This routine analyses the integer or floating literal given by the
 *    string str, constructing the corresponding expression.  The location
 *    given by ptok is assigned with lex_integer_Hexp or lex_floating_Hexp
 *    depending on the form of the literal.  Note that str can be an area
 *    of read-only memory for integer literals, but not for floating
 *    literals.
 */

EXP
make_literal_exp(string str, int *ptok, int force)
{
	EXP e;
	string r;
	int err = 0;
	int flt = 0;
	int pexp;
	string s = str;
	unsigned base = 10;
	string int_part, frac_part;
	string dot_posn = NULL;
	string exp_posn = NULL;
	int form = BASE_DECIMAL;

	/* Check small literals */
	character c1 = s [0];
	character c2 = 0;
	if (c1) c2 = s [1];
	if (c2 == 0 && (c1 >= char_zero && c1 <= char_nine)) {
		unsigned etag = exp_int_lit_tag;
		int n = (int) digit_values [c1];
		NAT lit = small_nat [n];
		if (IS_NULL_nat (lit)) lit = make_small_nat (n);
		if (n == 0) etag = exp_null_tag;
		MAKE_exp_int_lit (type_sint, lit, etag, e);
		*ptok = lex_integer_Hexp;
		return (e);
	}

	if (c1 == char_zero && (c2 == char_x || c2 == char_X)) {
		/* Hexadecimal literal */
		base = 16;
		form = BASE_HEXADECIMAL;
		s += 2;
	}

	int_part = s;
	s = check_digits (int_part, base);

	if (s[0] == char_dot) {
		dot_posn = s;
		/* Fractional component of floating literal */
		frac_part = s + 1;
		s = check_digits (frac_part, base);
		flt = 1;
	}

	exp_posn = s;
	pexp = (s[0] == char_p || s[0] == char_P);
	if (pexp || s[0] == char_e || s[0] == char_E) {
		/* Exponent component of floating literal */
		if (s[1] == char_plus || s[1] == char_minus) s++;
		r = s + 1;
		s = check_digits (r, 10);
		if (s == r) err = 1;
		flt = 1;
	}

	if (c1 == char_zero && base == 10 && !flt) {
		/* Octal integer */
		base = 8;
		form = BASE_OCTAL;
		r = check_digits (str, base);
		if (r != s) {
			/* Digits contain 8 or 9 */
			report (crt_loc, ERR_lex_icon_octal (str));
		}
	}

	if (flt) {
		/* Floating literals */
		int zero;
		NAT expon;
		character ep;
		string suff_posn = s;
		unsigned trail_zero = 0;
		FLOAT lit = NULL_flt;
		TYPE t = type_double;

		/* Exponent char and base must match.  Exponent must exist for
		 * hexadecimal floating point literals. */
		if ((base == 16) != pexp) {
			err = 1;
		}
		if (base == 16) {
			/* No digits */
			if (exp_posn - int_part <= 1) {
				if (exp_posn == int_part || dot_posn != NULL) err = 1;
			}
			report (crt_loc, ERR_lex_fcon_hex ());
		}

		/* Check float suffix */
		c1 = s [0];
		if (c1 == char_f || c1 == char_F) {
			/* Suffix F */
			t = type_float;
			s++;
			c1 = s [0];
		} else if (c1 == char_l || c1 == char_L) {
			/* Suffix L */
			t = type_ldouble;
			s++;
			c1 = s [0];
		}

		/* Check for end of number */
		if (c1 || err) report (crt_loc, ERR_lex_literal_bad (str));

		/* Find number components (involves writing to s)  */
		while (int_part [0] == char_zero) {
			/* Remove initial zeros */
			int_part++;
		}
		if (dot_posn) {
			dot_posn [0] = 0;
			if (int_part == dot_posn) int_part = small_number [0];
			if (frac_part == exp_posn) {
				frac_part = small_number [0];
			} else {
				/* Remove trailing zeros */
				string frac_zero = exp_posn - 1;
				while (frac_zero [0] == char_zero) {
					frac_zero [0] = 0;
					frac_zero--;
					trail_zero++;
				}
				if (frac_zero == dot_posn) frac_part = small_number [0];
			}
		} else {
			if (int_part == exp_posn) int_part = small_number [0];
			frac_part = small_number [0];
		}
		ep = exp_posn [0];
		exp_posn [0] = 0;
		if (ep == char_e || ep == char_E || ep == char_p || ep == char_P) {
			/* Evaluate exponent */
			r = exp_posn + 1;
			c2 = r [0];
			if (c2 == char_minus || c2 == char_plus) r++;
			expon = eval_digits (r, suff_posn, 10);
			if (c2 == char_minus) expon = negate_nat (expon);
			zero = is_zero_nat (expon);
		} else {
			expon = small_nat [0];
			zero = 1;
		}
		if (zero && ustreq (frac_part, small_number [0])) {
			int i;
			for (i = 0; i < SMALL_FLT_SIZE; i++) {
				if (ustreq (int_part, small_number [i])) {
					lit = get_float (t, i);
					break;
				}
			}
		}
		if (base == 16) {
			/* A hexadecimal floating point literal represents the value
			 * q*2^e where q is the mantissa and e the exponent.  For TDF's
			 * make_floating we have to convert that to q'*16^e' because the
			 * base value is used for the representation of the mantissa and
			 * the exponent. */
			unsigned long n;
			unsigned c;
			if (is_negative_nat (expon)) {
				/* q' = q >> (-e % 4)
				 * e' = -(-e / 4) */
				NAT m = negate_nat (expon);
				n = get_nat_value (m);
				if (n == EXTENDED_MAX) err = 1;
				expon = negate_nat (make_nat_value (n / 4));
				n %= 4;
			} else {
				/* q' = q >> (3 - (e + 3) % 4)
				 * e' = (e + 3) / 4 */
				n = get_nat_value (expon);
				if (n == EXTENDED_MAX) err = 1;
				expon = make_nat_value ((n + 3) / 4);
				n = 3 - ((n + 3) % 4);
			}
			/* Compute q' */
			int_part = shift_hex_string (int_part, n, 0, &c);
			frac_part = shift_hex_string (frac_part, n, c, NULL);
		} if (IS_NULL_flt (lit)) {
			int_part = ustring_copy (int_part);
			frac_part = ustring_copy (frac_part);
		}
		if (trail_zero) {
			/* Restore trailing zeros */
			r = exp_posn - 1;
			do {
				r [0] = char_zero;
				r--;
				trail_zero--;
			} while (trail_zero);
		}
		if (dot_posn) dot_posn [0] = char_dot;
		exp_posn [0] = ep;

		/* Construct result - type is as per suffix */
		if (IS_NULL_flt (lit)) {
			MAKE_flt_simple (int_part, frac_part, expon, lit);
			COPY_unsigned (flt_simple_base (lit), base);
		}
		MAKE_exp_float_lit (t, lit, e);
		*ptok = lex_floating_Hexp;

	} else {
		/* Integer literals */
		TYPE t;
		NAT lit;
		int ls = 0;
		int us = 0;
		int fit = 0;

		/* Find integer value */
		r = str;
		if (form == BASE_HEXADECIMAL) r += 2;
		lit = eval_digits (r, s, base);

		/* Check integer suffix */
		c1 = s [0];
		if (c1 == char_u || c1 == char_U) {
			us = 1;
			s++;
			c1 = s [0];
		}
		if (c1 == char_l || c1 == char_L) {
			ls = 1;
			if (s [1] == c1 && basetype_info [ntype_sllong].key) {
				report (crt_loc, ERR_lex_icon_llong (str));
				ls = 2;
				s++;
			}
			s++;
			c1 = s [0];
		} else {
			/* Map 'int' to 'long' in '#if' expressions */
			if (in_hash_if_exp) ls = 1;
		}
		if (us == 0 && (c1 == char_u || c1 == char_U)) {
			us = 1;
			s++;
			c1 = s [0];
		}

		/* Check for end of number */
		if (c1 || err) report (crt_loc, ERR_lex_literal_bad (str));

		/* Find literal type */
		if (force) {
			t = type_ulong;
			fit = 1;
		} else {
			int suff = SUFFIX (us, ls);
			t = find_literal_type (lit, form, suff, str, &fit);
		}
		MAKE_exp_int_lit (t, lit, exp_int_lit_tag, e);
		if (!fit) {
			/* Force result to be a calculated value */
			MAKE_exp_cast (t, CONV_INT_INT, e, e);
			MAKE_nat_calc (e, lit);
			MAKE_exp_int_lit (t, lit, exp_int_lit_tag, e);
		}
		*ptok = lex_integer_Hexp;
	}
	return (e);
}


/*
 *    IS A FLOATING LITERAL ZERO?
 *
 *    This routine checks whether the floating point literal f is zero.
 */

int
is_zero_float(FLOAT f)
{
	string s;
	character c;
	s = DEREF_string (flt_simple_int_part (f));
	while (c = *(s++), c != 0) {
		if (c != char_zero) return (0);
	}
	s = DEREF_string (flt_simple_frac_part (f));
	while (c = *(s++), c != 0) {
		if (c != char_zero) return (0);
	}
	return (1);
}


/*
 *    ARE TWO FLOATING LITERALS EQUAL?
 *
 *    This routine checks whether the floating point literals f and g are
 *    equal.  Note that this is equality of representation rather than
 *    equality of the underlying numbers.
 */

int
eq_float_lit(FLOAT f, FLOAT g)
{
	NAT ef, eg;
	ulong nf, ng;
	string af, ag;
	string bf, bg;
	unsigned cf, cg;
	if (EQ_flt (f, g)) return (1);
	DECONS_flt_simple (nf, af, bf, ef, cf, f);
	DECONS_flt_simple (ng, ag, bg, eg, cg, g);
	if (!ustreq (af, ag)) return (0);
	if (!ustreq (bf, bg)) return (0);
	if (cf != cg) return (0);
	if (compare_nat (ef, eg) != 0) return (0);
	if (nf == LINK_NONE) COPY_ulong (flt_tok (f), ng);
	if (ng == LINK_NONE) COPY_ulong (flt_tok (g), nf);
	return (1);
}


/*
 *    DEFAULT ROUNDING MODE
 *
 *    This variable gives the default rounding mode used for converting
 *    floating point expressions to integers.
 */

RMODE crt_round_mode = rmode_to_zero;


/*
 *    ROUND A FLOATING POINT LITERAL
 *
 *    This routine rounds the floating point literal f to an integer
 *    literal by the rounding mode corresponding to mode.  The null integer
 *    literal is returned to indicate a target dependent literal.  The
 *    range of values in which the result is target independent is actually
 *    rather small - it is given by FLT_DIG.
 */

NAT
round_float_lit(FLOAT f, RMODE mode)
{
	NAT res;
	unsigned long i, j, n;
	unsigned long res_len;
	unsigned long pre_len;
	unsigned long exp_val;
	character result [100];

	/* Decompose simple literal */
	string int_part = DEREF_string (flt_simple_int_part (f));
	string frac_part = DEREF_string (flt_simple_frac_part (f));
	unsigned base = DEREF_unsigned (flt_simple_base (f));
	NAT expon = DEREF_nat (flt_simple_exponent (f));

	/* Find component lengths */
	unsigned long int_len = (unsigned long) ustrlen (int_part);
	unsigned long frac_len = (unsigned long) ustrlen (frac_part);

	/* Allow for initial zeros */
	while (int_part [0] == char_zero) {
		int_part++;
		int_len--;
	}

	/* Allow for exponent */
	if (IS_nat_neg (expon)) {
		expon = DEREF_nat (nat_neg_arg (expon));
		exp_val = get_nat_value (expon);
		if (exp_val > int_len) {
			res_len = 0;
			pre_len = exp_val - int_len;
		} else {
			res_len = int_len - exp_val;
			pre_len = 0;
		}
	} else {
		exp_val = get_nat_value (expon);
		res_len = int_len + exp_val;
		pre_len = 0;
	}

	/* Allow for initial zeros in fractional part */
	if (int_part [0] == 0) {
		while (frac_part [0] == char_zero) {
			frac_part++;
			frac_len--;
			if (res_len == 0) {
				pre_len++;
			} else {
				res_len--;
			}
		}
		if (frac_part [0] == 0) {
			/* Zero floating literal */
			res = small_nat [0];
			return (res);
		}
	}

	/* Extreme values are target dependent */
	if (pre_len > 6) return (NULL_nat);
	if (res_len > 6) return (NULL_nat);
	if (exp_val == EXTENDED_MAX) return (NULL_nat);

	/* Construct integer string */
	j = 0;
	n = res_len;
	for (i = 0; i < pre_len; i++) {
		if (j < n) {
			result [j] = char_zero;
			j++;
		}
	}
	for (i = 0; i < int_len; i++) {
		if (j < n) {
			result [j] = int_part [i];
			j++;
		}
	}
	for (i = 0; i < frac_len; i++) {
		if (j < n) {
			result [j] = frac_part [i];
			j++;
		}
	}
	for (; j < n; j++) result [j] = char_zero;
	result [n] = 0;

	/* Calculate the result */
	res = eval_digits (result, result + res_len, base);
	UNUSED (mode);
	return (res);
}


/*
 *    EVALUATE A UNICODE CHARACTER
 *
 *    This routine evaluates the unicode character with prefix c, consisting
 *    of n hex digits, given by ps.  ps is advanced to the position following
 *    the hex digits.
 */

unsigned long
eval_unicode(int c, unsigned n, int *pc, string *ps, ERROR *err)
{
	string r = *ps;
	unsigned long u;
	unsigned base = 16;
	string s = check_digits (r, base);
	unsigned m = (unsigned) (s - r);
	if (m < n) {
		add_error (err, ERR_lex_charset_len (c, n));
	} else {
		s = r + n;
	}
	*ps = s;
	u = eval_char_digits (r, s, base);
	add_error (err, ERR_lex_charset_replace (u));
	if (u < 0x20 || (u >= 0x7f && u <= 0x9f) || is_legal_char (u)) {
		add_error (err, ERR_lex_charset_bad (u));
		*pc = CHAR_SIMPLE;
	} else {
		if (u <= (unsigned long) 0xffff) *pc = CHAR_UNI4;
	}
	return (u);
}


/*
 *    GET A MULTI-BYTE CHARACTER FROM A STRING
 *
 *    This routine returns the multi-byte character pointed to by the
 *    string s.  It assigns the character type to pc.
 */

unsigned long
get_multi_char(string s, int *pc)
{
	int i;
	unsigned long n = 0;
	for (i = MULTI_WIDTH - 1; i >= 1; i--) {
		n = (n << 8) + (unsigned long) s [i];
	}
	*pc = (int) s [0];
	return (n);
}


/*
 *    ADD A MULTI-BYTE CHARACTER TO A STRING
 *
 *    This routine adds the multi-byte character n of type ch to the
 *    string s.  A multi-byte character is represented by 5 characters.
 *    The first is a key describing how the character was described (a
 *    simple character, a hex or octal escape sequence, a unicode
 *    character etc.).  The next four characters give the character value.
 */

void
add_multi_char(string s, unsigned long n, int ch)
{
	int i;
	s [0] = (character) ch;
	for (i = 1; i < MULTI_WIDTH; i++) {
		s [i] = (character) (n & 0xff);
		n >>= 8;
	}
	if (n) report (crt_loc, ERR_lex_ccon_large ());
	return;
}


/*
 *    CREATE A MULTI-BYTE STRING
 *
 *    This routine creates a multi-byte string of length n in s from the
 *    string t of kind k.
 */

static void
make_multi_string(string s, string t, unsigned long n, unsigned k)
{
	if (k & STRING_MULTI) {
		n *= MULTI_WIDTH;
		xumemcpy (s, t, (size_t) n);
	} else {
		unsigned long i;
		for (i = 0; i < n; i++) {
			add_multi_char (s, (unsigned long) *t, CHAR_SIMPLE);
			s += MULTI_WIDTH;
			t++;
		}
	}
	return;
}


/*
 *    GET A MULTIBYTE CHARACTER FROM A STRING
 *
 *    This routine reads a multibyte character from the string s (which
 *    ends at se).  The value (as a wide character) is assigned to pc with
 *    the new value of s being returned.  Note that this routine is not
 *    required in, for example, check_digits because the representation
 *    of a simple single byte character as a multibyte character comprises
 *    that single byte.
 */

#if FS_MULTIBYTE

static string
get_multibyte(string s, string se, unsigned long *pc)
{
	wchar_t c;
	int n = mbtowc (&c, s, (size_t) (se - s));
	if (n > 0) {
		/* Valid multibyte character */
		*pc = (unsigned long) c;
		s += n;
	} else if (n == 0) {
		/* Null character */
		*pc = 0;
		s++;
	} else {
		/* Invalid multibyte character */
		report (crt_loc, ERR_lex_ccon_multibyte ());
		*pc = (unsigned long) *(s++);
	}
	return (s);
}

#endif


/*
 *    ANALYSE A STRING OR CHARACTER LITERAL
 *
 *    This routine analyses the string or character literal given by the
 *    string s (which ends at se).  Only characters in the range [0,0xff]
 *    are assumed to be valid. Note that this is the routine which should
 *    do the mapping from the source character set to the execution
 *    character set (translation phase 5), however this is deferred until
 *    the string output routines.
 */

STRING
new_string_lit(string s, string se, int lex)
{
	STRING res;
	STRING prev;
	int multi = 0;
	int overflow = 0;
	unsigned long len = 0;
	unsigned kind = STRING_NONE;
#if FS_MULTIBYTE
	int multibyte = allow_multibyte;
#endif
	size_t sz = (size_t) (se - s) + 1;
	string str = ustring_alloc (sz);

	/* Find string type */
	switch (lex) {
	case lex_char_Hlit :
	case lex_char_Hexp : {
		kind = STRING_CHAR;
		break;
	}
	case lex_wchar_Hlit :
	case lex_wchar_Hexp : {
		kind = (STRING_WIDE | STRING_CHAR);
		break;
	}
	case lex_string_Hlit :
	case lex_string_Hexp : {
		kind = STRING_NONE;
		break;
	}
	case lex_wstring_Hlit :
	case lex_wstring_Hexp : {
		kind = STRING_WIDE;
		break;
	}
	}
	if (do_string) dump_string_lit (s, se, kind);

	/* Scan string replacing escape sequences */
	while (s != se) {
		unsigned long c;
		int ch = CHAR_SIMPLE;
#if FS_MULTIBYTE
		if (multibyte) {
			s = get_multibyte (s, se, &c);
		} else {
			c = (unsigned long) *(s++);
		}
#else
		c = (unsigned long) *(s++);
#endif
		if (c == char_backslash) {
			if (s != se) {
				/* Unterminated string literals already reported */
				character e = NONE;
#if FS_MULTIBYTE
				if (multibyte) {
					s = get_multibyte (s, se, &c);
				} else {
					c = (unsigned long) *(s++);
				}
#else
				c = (unsigned long) *(s++);
#endif
				if (c < NO_CHAR) e = escape_sequences [c];
				switch (e) {

				case OCTE : {
					/* Octal escape sequences */
					unsigned base = 8;
					string r = s - 1;
					s = check_digits (r, base);
					if (s > r + 3) s = r + 3;
					c = eval_char_digits (r, s, base);
					ch = CHAR_OCTAL;
					break;
				}

				case HEXE : {
					/* Hexadecimal escape sequences */
					unsigned base = 16;
					string r = s;
					s = check_digits (r, base);
					if (s == r) {
						int i = (int) c;
						report (crt_loc, ERR_lex_ccon_hex (i));
					} else {
						c = eval_char_digits (r, s, base);
					}
					ch = CHAR_HEX;
					break;
				}

				case UNI4 : {
					/* Short unicode escape sequences */
					if (allow_unicodes) {
						string r = s;
						unsigned d = 4;
						ERROR err = NULL_err;
						c = eval_unicode (char_u, d, &ch, &r, &err);
						if (!IS_NULL_err (err)) {
							report (crt_loc, err);
						}
						ch = CHAR_UNI4;
						s = r;
						break;
					}
					goto illegal_lab;
				}

				case UNI8 : {
					/* Long unicode escape sequences */
					if (allow_unicodes) {
						string r = s;
						unsigned d = 8;
						ERROR err = NULL_err;
						c = eval_unicode (char_U, d, &ch, &r, &err);
						if (!IS_NULL_err (err)) {
							report (crt_loc, err);
						}
						ch = CHAR_UNI8;
						s = r;
						break;
					}
					goto illegal_lab;
				}

				case NONE :
					illegal_lab : {
						/* Illegal escape sequences */
						int i = (int) c;
						report (crt_loc, ERR_lex_ccon_escape (i));
						break;
					}

				default : {
					/* Simple escape sequences */
					c = (unsigned long) e;
					break;
				}
				}
			}
		}
		if ((ch != CHAR_SIMPLE || c >= 256) && !multi) {
			/* Convert to multi-character format */
			string a;
			sz *= MULTI_WIDTH;
			a = ustring_alloc (sz);
			make_multi_string (a, str, len, kind);
			if (len) {
				len *= MULTI_WIDTH;
				if (len == 0) overflow = 1;
			}
			if (c >= 256) {
				/* Mark fat strings */
				if (!(kind & STRING_WIDE)) {
					if (ch == CHAR_UNI4 || ch == CHAR_UNI8) {
						/* EMPTY */
					} else {
						report (crt_loc, ERR_lex_ccon_large ());
					}
				}
				kind |= STRING_FAT;
			}
			kind |= STRING_MULTI;
			multi = 1;
			str = a;
		}
		if (multi) {
			add_multi_char (str + len, c, ch);
			len += MULTI_WIDTH;
		} else {
			str [len++] = (character) c;
		}
		if (len == 0) overflow = 1;
	}
	if (multi) {
		add_multi_char (str + len, (unsigned long) 0, CHAR_OCTAL);
		len /= MULTI_WIDTH;
	} else {
		str [len] = 0;
	}
	if (overflow) len = ULONG_MAX;
	if (!check_value (OPT_VAL_string_length, len)) {
		len = option_value (OPT_VAL_string_length);
		if (multi) {
			unsigned long n = MULTI_WIDTH * len;
			add_multi_char (str + n, (unsigned long) 0, CHAR_OCTAL);
		} else {
			str [len] = 0;
		}
	}
	MAKE_str_simple (len, str, kind, res);
	prev = share_string_lit (res);
	if (!EQ_str (prev, res)) {
		/* Share string literals */
		unsigned long v;
		DESTROY_str_simple (destroy, res, len, str, kind, v, res);
		ustring_free (str);
		UNUSED (res);
		UNUSED (len);
		UNUSED (kind);
		UNUSED (v);
		res = prev;
	}
	return (res);
}


/*
 *    ARE TWO STRINGS EQUAL?
 *
 *    This routine checks whether the string literals s and t are equal.
 */

int
eq_string_lit(STRING s, STRING t)
{
	string as, at;
	unsigned ks, kt;
	unsigned long ns, nt;
	if (EQ_str (s, t)) return (1);
	ks = DEREF_unsigned (str_simple_kind (s));
	kt = DEREF_unsigned (str_simple_kind (t));
	ns = DEREF_ulong (str_simple_len (s));
	nt = DEREF_ulong (str_simple_len (t));
	if (ks == kt && ns == nt) {
		as = DEREF_string (str_simple_text (s));
		at = DEREF_string (str_simple_text (t));
		if (as == at) return (1);
		if (ks & STRING_MULTI) ns *= MULTI_WIDTH;
		if (xumemcmp (as, at, (size_t) ns) == 0) return (1);
	}
	return (0);
}


/*
 *    CONCATENATE TWO STRING LITERALS
 *
 *    This routine concatenates the string literals s and t.
 */

STRING
concat_string_lit(STRING s, STRING t)
{
	string c;
	STRING res;
	STRING prev;
	unsigned kc;
	size_t sz;
	unsigned long nc;
	string a = DEREF_string (str_simple_text (s));
	string b = DEREF_string (str_simple_text (t));
	unsigned ka = DEREF_unsigned (str_simple_kind (s));
	unsigned kb = DEREF_unsigned (str_simple_kind (t));
	unsigned long na = DEREF_ulong (str_simple_len (s));
	unsigned long nb = DEREF_ulong (str_simple_len (t));

	/* Form the result literal */
	if (na == 0) return (t);
	if (nb == 0) return (s);
	nc = na + nb;
	if (nc < na || nc < nb) nc = ULONG_MAX;
	if (!check_value (OPT_VAL_string_length, nc)) {
		nc = option_value (OPT_VAL_string_length);
		nb = nc - na;
	}
	kc = (ka | kb);
	if (kc & STRING_MULTI) {
		/* Multi-byte strings */
		unsigned long sa = MULTI_WIDTH * na;
		unsigned long sc = MULTI_WIDTH * nc;
		sz = (size_t) (sc + MULTI_WIDTH);
		c = ustring_alloc (sz);
		make_multi_string (c, a, na, ka);
		make_multi_string (c + sa, b, nb, kb);
		add_multi_char (c + sc, (unsigned long) 0, CHAR_OCTAL);
	} else {
		/* Simple strings */
		sz = (size_t) (nc + 1);
		c = ustring_alloc (sz);
		xumemcpy (c, a, (size_t) na);
		xumemcpy (c + na, b, (size_t) nb);
		c [nc] = 0;
	}
	MAKE_str_simple (nc, c, kc, res);
	prev = share_string_lit (res);
	if (!EQ_str (prev, res)) {
		/* Share string literals */
		unsigned long v;
		DESTROY_str_simple (destroy, res, nc, c, kc, v, res);
		ustring_free (c);
		UNUSED (res);
		UNUSED (nc);
		UNUSED (kc);
		UNUSED (v);
		res = prev;
	}
	return (res);
}


/*
 *    FIND THE SHARED COPY OF A STRING LITERAL
 *
 *    This routine is used to implement shared string literals.  It returns
 *    the canonical copy of s (i.e. the first string equal to s for which
 *    the routine was called).
 */

STRING
share_string_lit(STRING s)
{
	string a = DEREF_string (str_simple_text (s));
	unsigned long h = (hash (a) % HASH_STRING_SIZE);
	STRING p = string_hash_table [h];
	STRING t = p;
	while (!IS_NULL_str (t)) {
		if (eq_string_lit (t, s)) return (t);
		t = DEREF_str (str_next (t));
	}
	COPY_str (str_next (s), p);
	string_hash_table [h] = s;
	return (s);
}


/*
 *    GET THE NEXT CHARACTER FROM A STRING
 *
 *    This routine returns the next character from the string s, using
 *    the tok field as a counter.  The character type is assigned to pc,
 *    including CHAR_NONE to indicate the end of the string.
 */

unsigned long
get_string_char(STRING s, int *pc)
{
	unsigned long c;
	unsigned long i = DEREF_ulong (str_simple_tok (s));
	unsigned long n = DEREF_ulong (str_simple_len (s));
	if (i < n) {
		string text = DEREF_string (str_simple_text (s));
		unsigned kind = DEREF_unsigned (str_simple_kind (s));
		if (kind & STRING_MULTI) {
			c = get_multi_char (text + MULTI_WIDTH * i, pc);
		} else {
			c = (unsigned long) text [i];
			*pc = CHAR_SIMPLE;
		}
	} else {
		c = 0;
		*pc = CHAR_NONE;
	}
	COPY_ulong (str_simple_tok (s), i + 1);
	return (c);
}


/*
 *    FIND A CHARACTER LITERAL
 *
 *    This routine returns the character value corresponding to the character
 *    literal expression e.
 */

int
get_char_value(EXP e)
{
	int c = char_illegal;
	if (!IS_NULL_exp (e)) {
		if (IS_exp_int_lit (e)) {
			NAT n = DEREF_nat (exp_int_lit_nat (e));
			if (IS_nat_calc (n)) {
				e = DEREF_exp (nat_calc_value (n));
			}
		}
		if (IS_exp_cast (e)) {
			e = DEREF_exp (exp_cast_arg (e));
			if (IS_exp_int_lit (e)) {
				NAT n = DEREF_nat (exp_int_lit_nat (e));
				if (IS_nat_calc (n)) {
					e = DEREF_exp (nat_calc_value (n));
				}
			}
		}
		if (IS_exp_char_lit (e)) {
			STRING s = DEREF_str (exp_char_lit_str (e));
			unsigned kind = DEREF_unsigned (str_simple_kind (s));
			if (!(kind & STRING_MULTI)) {
				unsigned long len = DEREF_ulong (str_simple_len (s));
				if (len == 1) {
					string t = DEREF_string (str_simple_text (s));
					c = (int) *t;
				}
			}
		}
	}
	return (c);
}


/*
 *    EVALUATE A CHARACTER LITERAL
 *
 *    This routine evaluates the character literal str by mapping it to
 *    its ASCII representation.  The value is stored in the tok field
 *    (the fact that LINK_NONE equals EXTENDED_MAX is convenient, but not
 *    essential).
 */

NAT
eval_char_lit(STRING str)
{
	NAT n;
	unsigned long v = DEREF_ulong (str_simple_tok (str));
	if (v == LINK_NONE) {
		unsigned long i;
		string s = DEREF_string (str_simple_text (str));
		unsigned long len = DEREF_ulong (str_simple_len (str));
		unsigned kind = DEREF_unsigned (str_simple_kind (str));
		if (kind & STRING_MULTI) {
			NAT b = make_small_nat (256);
			n = small_nat [0];
			for (i = 0; i < len; i++) {
				NAT d;
				int ch = CHAR_SIMPLE;
				unsigned long c = get_multi_char (s, &ch);
				if (ch == CHAR_SIMPLE) c = to_ascii (c, &ch);
				d = make_nat_value (c);
				n = binary_nat_op (exp_mult_tag, n, b);
				n = binary_nat_op (exp_plus_tag, n, d);
				s += MULTI_WIDTH;
			}
		} else {
			n = small_nat [0];
			for (i = 0; i < len; i++) {
				int ch = CHAR_SIMPLE;
				unsigned long c = (unsigned long) *s;
				c = to_ascii (c, &ch);
				n = make_nat_literal (n, (unsigned) 256, (unsigned) c);
				s++;
			}
		}
		v = get_nat_value (n);
		if (v != EXTENDED_MAX) {
			/* Store calculated value */
			COPY_ulong (str_simple_tok (str), v);
		}
	} else {
		/* Use stored value */
		n = make_nat_value (v);
	}
	return (n);
}


/*
 *    FIND A CHARACTER REPRESENTATION TYPE
 *
 *    In the case where a character literal type doesn't fit into its type
 *    then this routine gives a type in which the literal value can be
 *    constructed and then converted into its underlying type.
 */

TYPE
find_char_type(NAT n)
{
	TYPE t;
	int fit = 0;
	string str = NULL_string;
	t = find_literal_type (n, BASE_OCTAL, SUFFIX_NONE, str, &fit);
	return (t);
}


/*
 *    CREATE A STRING OR CHARACTER LITERAL EXPRESSION
 *
 *    This routine turns a string or character literal into an expression.
 *    Note that the type of a normal character literal varies between C
 *    (where it is a char cast to an int) and C++ (where it stays as a
 *    char), and also that a string, or wide string, literal is an lvalue
 *    of array type.
 */

EXP
make_string_exp(STRING s)
{
	EXP e;
	string text = DEREF_string (str_simple_text (s));
	unsigned long len = DEREF_ulong (str_simple_len (s));
	unsigned kind = DEREF_unsigned (str_simple_kind (s));

	if (kind & STRING_CHAR) {
		int fits = 0;
		int digit = -1;
		TYPE t0, t1, t2;
		NAT n = NULL_nat;
		ERROR err = NULL_err;
		if (kind & STRING_WIDE) {
			t0 = type_wchar_lit;
			t1 = t0;
			t2 = t0;
		} else if (len <= 1) {
			t0 = type_char;
			t1 = t0;
			t2 = type_char_lit;
		} else {
			report (crt_loc, ERR_lex_ccon_multi (s));
			t0 = type_mchar_lit;
			t1 = t0;
			t2 = t0;
		}
		if (len == 0) {
			fits = 1;
			n = small_nat [0];
			COPY_ulong (str_simple_tok (s), 0);
		} else if (len == 1) {
			if (kind & STRING_MULTI) {
				if (!(kind & STRING_FAT)) {
					/* Simple octal or hex escape sequence */
					unsigned long v = DEREF_ulong (str_simple_tok (s));
					if (v == LINK_NONE) {
						int ch = CHAR_SIMPLE;
						v = get_multi_char (text, &ch);
						if (ch == CHAR_OCTAL || ch == CHAR_HEX) {
							if (v < 128) fits = 1;
							n = make_nat_value (v);
							COPY_ulong (str_simple_tok (s), v);
						}
					} else {
						if (v < 128) fits = 1;
						n = make_nat_value (v);
					}
				}
			} else {
				/* Single character */
				character c = text [0];
				if (in_hash_if_exp) {
					/* Evaluate character value immediately */
					unsigned long v = DEREF_ulong (str_simple_tok (s));
					if (v == LINK_NONE) {
						int ch = CHAR_SIMPLE;
						v = (unsigned long) c;
						v = to_ascii (v, &ch);
						COPY_ulong (str_simple_tok (s), v);
					}
					if (v < 128) fits = 1;
					n = make_nat_value (v);
				} else {
					if (c >= char_zero && c <= char_nine) {
						/* Allow for digits */
						digit = (int) (c - char_zero);
					}
				}
			}
		}
		if (IS_NULL_nat (n)) {
			/* Make character literal expression */
			MAKE_exp_char_lit (t0, s, digit, e);
			MAKE_nat_calc (e, n);
		} else {
			if (!fits && check_nat_range (t0, n) != NAT_FIT) {
				/* Value doesn't fit into t0 */
				t0 = find_char_type (n);
			}
		}
		MAKE_exp_int_lit (t0, n, exp_char_lit_tag, e);
		if (!EQ_type (t0, t1)) {
			/* Convert from t0 to t1 */
			e = make_cast_nat (t1, e, &err, CAST_STATIC);
		}
		if (!EQ_type (t1, t2)) {
			/* Convert from t1 to t2 */
			e = make_cast_nat (t2, e, &err, CAST_IMPLICIT);
		}
		if (!IS_NULL_err (err)) report (crt_loc, err);
	} else {
		/* String literals */
		TYPE t;
		NAT n = make_nat_value (len + 1);
		if (kind & STRING_WIDE) {
			t = type_wstring_lit;
		} else {
			t = type_string_lit;
		}
		MAKE_type_array (cv_lvalue, t, n, t);
		MAKE_exp_string_lit (t, s, e);
	}
	return (e);
}


/*
 *    CREATE A BOOLEAN LITERAL EXPRESSION
 *
 *    This routine creates a boolean literal expression given by the boolean
 *    value b (which should be one of the values BOOL_FALSE and BOOL_TRUE
 *    defined in literal.h).
 */

EXP
make_bool_exp(unsigned b, unsigned tag)
{
	EXP e;
	NAT n = small_nat [b];
	MAKE_exp_int_lit (type_bool, n, tag, e);
	return (e);
}


/*
 *    TEST A BOOLEAN LITERAL EXPRESSION
 *
 *    This routine is the reverse of the one above.  It returns the boolean
 *    value (BOOL_FALSE, BOOL_TRUE or BOOL_UNKNOWN) corresponding to the
 *    expression e.
 */

unsigned
test_bool_exp(EXP e)
{
	NAT n = DEREF_nat (exp_int_lit_nat (e));
	if (IS_nat_small (n)) {
		unsigned b = DEREF_unsigned (nat_small_value (n));
		if (b == BOOL_FALSE) return (BOOL_FALSE);
		if (b == BOOL_TRUE) return (BOOL_TRUE);
	}
	return (BOOL_UNKNOWN);
}
