/*
* 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);
}
syntax highlighted by Code2HTML, v. 0.9.1