Subversion Repositories tendra.SVN

Rev

Rev 5 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 7u83 1 
/*
6 7u83 2 
 * Copyright (c) 2002-2005 The TenDRA Project <http://www.tendra.org/>.
3 
 * All rights reserved.
4 
 *
5 
 * Redistribution and use in source and binary forms, with or without
6 
 * modification, are permitted provided that the following conditions are met:
7 
 *
8 
 * 1. Redistributions of source code must retain the above copyright notice,
9 
 *    this list of conditions and the following disclaimer.
10 
 * 2. Redistributions in binary form must reproduce the above copyright notice,
11 
 *    this list of conditions and the following disclaimer in the documentation
12 
 *    and/or other materials provided with the distribution.
13 
 * 3. Neither the name of The TenDRA Project nor the names of its contributors
14 
 *    may be used to endorse or promote products derived from this software
15 
 *    without specific, prior written permission.
16 
 *
17 
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
18 
 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
19 
 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
20 
 * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
21 
 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
22 
 * EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
23 
 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
24 
 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
26 
 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
27 
 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28 
 *
29 
 * $Id$
30 
 */
31 
/*
2 7u83 32 
    		 Crown Copyright (c) 1997, 1998
6 7u83 33 
 
2 7u83 34 
    This TenDRA(r) Computer Program is subject to Copyright
35 
    owned by the United Kingdom Secretary of State for Defence
36 
    acting through the Defence Evaluation and Research Agency
37 
    (DERA).  It is made available to Recipients with a
38 
    royalty-free licence for its use, reproduction, transfer
39 
    to other parties and amendment for any purpose not excluding
40 
    product development provided that any such use et cetera
41 
    shall be deemed to be acceptance of the following conditions:-
6 7u83 42 
 
2 7u83 43 
        (1) Its Recipients shall ensure that this Notice is
44 
        reproduced upon any copies or amended versions of it;
6 7u83 45 
 
2 7u83 46 
        (2) Any amended version of it shall be clearly marked to
47 
        show both the nature of and the organisation responsible
48 
        for the relevant amendment or amendments;
6 7u83 49 
 
2 7u83 50 
        (3) Its onward transfer from a recipient to another
51 
        party shall be deemed to be that party's acceptance of
52 
        these conditions;
6 7u83 53 
 
2 7u83 54 
        (4) DERA gives no warranty or assurance as to its
55 
        quality or suitability for any purpose and DERA accepts
56 
        no liability whatsoever in relation to any use to which
57 
        it may be put.
58 
*/
59 
 
60 
 
61 
#include "config.h"
62 
#include <limits.h>
63 
#include "c_types.h"
64 
#include "exp_ops.h"
65 
#include "flt_ops.h"
66 
#include "id_ops.h"
67 
#include "itype_ops.h"
68 
#include "nat_ops.h"
69 
#include "str_ops.h"
70 
#include "type_ops.h"
71 
#include "error.h"
72 
#include "catalog.h"
73 
#include "option.h"
74 
#include "basetype.h"
75 
#include "cast.h"
76 
#include "char.h"
77 
#include "chktype.h"
78 
#include "constant.h"
79 
#include "convert.h"
80 
#include "dump.h"
81 
#include "exception.h"
82 
#include "expression.h"
83 
#include "hash.h"
84 
#include "inttype.h"
85 
#include "lex.h"
86 
#include "literal.h"
87 
#include "preproc.h"
88 
#include "syntax.h"
89 
#include "tok.h"
90 
#include "token.h"
91 
#include "ustring.h"
92 
#include "xalloc.h"
93 
 
94 
 
95 
/*
96 
    SPECIAL TABLE VALUES
97 
 
98 
    These macros are used in the tables of digits and escape sequences
99 
    to indicate special values.
100 
*/
101 
 
102 
#define NONE			0xff
103 
#define OCTE			0xfe
104 
#define HEXE			0xfd
105 
#define UNI4			0xfc
106 
#define UNI8			0xfb
107 
 
108 
 
109 
/*
110 
    TABLE OF DIGITS
111 
 
112 
    This table gives the mapping of characters to digits.  The default
113 
    table assumes the ASCII character set, for other codesets it needs
114 
    to be rewritten.  The valid digits are 0-9, A-Z (which evaluate to
115 
    10-35) and a-z (which evaluate to 10-35).  Invalid digits are
116 
    indicated by NONE.
117 
*/
118 
 
6 7u83 119 
unsigned char digit_values[NO_CHAR + 1] = {
120 
#define CHAR_DATA(A, B, C, D)	(B),
2 7u83 121 
#include "char.h"
122 
#undef CHAR_DATA
6 7u83 123 
	NONE		/* dummy */
124 
};
2 7u83 125 
 
126 
 
127 
/*
128 
    TABLE OF ESCAPE SEQUENCES
129 
 
130 
    This table gives the mapping of characters to escape sequences.  The
131 
    default table assumes the ASCII character set, for other codesets it
132 
    needs to be rewritten.  The valid escape sequences are \', \", \?,
133 
    \\, \a, \b, \f, \n, \r, \t and \v.  Octal escape sequences are
134 
    indicated by OCTE, hexadecimal escape sequences by HEXE, universal
135 
    character names by UNI4 or UNI8, and illegal escape sequences by
136 
    NONE.
137 
*/
138 
 
6 7u83 139 
unsigned char escape_sequences[NO_CHAR + 1] = {
140 
#define CHAR_DATA(A, B, C, D)	(C),
2 7u83 141 
#include "char.h"
142 
#undef CHAR_DATA
6 7u83 143 
	NONE		/* dummy */
144 
};
2 7u83 145 
 
146 
 
147 
/*
148 
    SET AN ESCAPE SEQUENCE
149 
 
150 
    This routine sets the character escape value for the character
151 
    literal expression a to be the character literal b, or an illegal
152 
    escape if b is the null expression.
153 
*/
154 
 
6 7u83 155 
void
156 
set_escape(EXP a, EXP b)
2 7u83 157 
{
6 7u83 158 
	int c = get_char_value(a);
159 
	int e = NONE;
160 
	if (!IS_NULL_exp(b)) {
161 
		e = get_char_value(b);
162 
		if (e == char_illegal) {
163 
			e = NONE;
164 
		}
165 
	}
166 
	if (c >= 0 && c < NO_CHAR) {
167 
		escape_sequences[c] = (unsigned char)e;
168 
	}
169 
	return;
2 7u83 170 
}
171 
 
172 
 
173 
/*
174 
    CHECK A STRING OF DIGITS
175 
 
176 
    This routine scans the string s for valid digits for the given base.
177 
    It returns a pointer to the first character which is not a valid
178 
    digit.
179 
*/
180 
 
6 7u83 181 
static string
182 
check_digits(string s, unsigned base)
2 7u83 183 
{
6 7u83 184 
	unsigned b;
185 
	character c;
186 
	while (c = *s, c != 0) {
2 7u83 187 
#if FS_EXTENDED_CHAR
6 7u83 188 
		if (IS_EXTENDED(c)) {
189 
			break;
190 
		}
2 7u83 191 
#endif
6 7u83 192 
		b = (unsigned)digit_values[c];;
193 
		if (b >= base) {
194 
			break;
195 
		}
196 
		s++;
197 
	}
198 
	return(s);
2 7u83 199 
}
200 
 
201 
 
202 
/*
203 
    EVALUATE A STRING OF DIGITS
204 
 
205 
    This routine evaluates the string of digits starting with s and
206 
    ending with t using the given base (which will be at most 16).  It
207 
    is assumed that all of these digits are in the correct range.
208 
*/
209 
 
6 7u83 210 
static NAT
211 
eval_digits(string s, string t, unsigned base)
2 7u83 212 
{
6 7u83 213 
	NAT n;
214 
	int m = 0;
215 
	string r = s;
216 
	unsigned long v = 0;
217 
	unsigned long b = (unsigned long)base;
218 
	while (r != t && m < 8) {
219 
		/* Evaluate first few digits */
220 
		unsigned long d = (unsigned long)digit_values[*r];
221 
		v = b * v + d;
222 
		m++;
223 
		r++;
224 
	}
225 
	n = make_nat_value(v);
226 
	while (r != t) {
227 
		/* Evaluate further digits */
228 
		unsigned d = (unsigned)digit_values[*r];
229 
		n = make_nat_literal(n, base, d);
230 
		r++;
231 
	}
232 
	return(n);
2 7u83 233 
}
234 
 
235 
 
236 
/*
237 
    EVALUATE A STRING OF DIGITS
238 
 
239 
    This routine is the same as eval_digits except that it assumes that
240 
    the result fits inside an unsigned long, and reports an error
241 
    otherwise.
242 
*/
243 
 
6 7u83 244 
static unsigned long
245 
eval_char_digits(string s, string t, unsigned base)
2 7u83 246 
{
6 7u83 247 
	string r;
248 
	int overflow = 0;
249 
	unsigned long n = 0;
250 
	unsigned long b = (unsigned long)base;
251 
	for (r = s; r != t; r++) {
252 
		unsigned long m = n;
253 
		n = b * n + (unsigned long)digit_values[*r];
254 
		if (n < m) {
255 
			overflow = 1;
256 
		}
257 
	}
258 
	if (overflow) {
259 
		report(crt_loc, ERR_lex_ccon_large());
260 
	}
261 
	return(n);
2 7u83 262 
}
263 
 
264 
 
265 
/*
266 
    EVALUATE A LINE NUMBER
267 
 
268 
    This routine evaluates the sequence of decimal digits s as a line
269 
    number in a #line, or similar, preprocessing directive.  Any errors
270 
    arising are indicated using err.  This is a bit pattern consisting
271 
    of 2 if s is not a simple string of decimal digits, and 1 if its
272 
    value exceeds 32767.
273 
*/
274 
 
6 7u83 275 
unsigned long
276 
eval_line_digits(string s, unsigned *err)
2 7u83 277 
{
6 7u83 278 
	string r;
279 
	unsigned e = 0;
280 
	unsigned long n = 0;
281 
	string t = check_digits(s, (unsigned)10);
282 
	if (*t) {
283 
		e = 2;
284 
	}
285 
	for (r = s; r != t; r++) {
286 
		n = 10 * n + (unsigned long)digit_values[*r];
287 
		if (n > 0x7fff) {
288 
			e |= 1;
289 
		}
290 
	}
291 
	*err = e;
292 
	return(n);
2 7u83 293 
}
294 
 
295 
 
296 
/*
297 
    STRING HASH TABLE
298 
 
299 
    This variable gives the hash table used in shared string literals.
300 
*/
301 
 
6 7u83 302 
static STRING *string_hash_table = NULL;
303 
#define HASH_STRING_SIZE	((unsigned long)256)
2 7u83 304 
 
305 
 
306 
/*
307 
    STRING AND CHARACTER LITERAL TYPES
308 
 
309 
    The type of a simple character literal is char in C++, but int in C.
310 
    The variable type_char_lit is used to hold the appropriate result
311 
    type.  Other string and character literals have fixed types, however
312 
    for convenience variables are used to identify them.
313 
*/
314 
 
6 7u83 315 
static TYPE type_char_lit;
316 
static TYPE type_mchar_lit;
317 
static TYPE type_wchar_lit;
318 
static TYPE type_string_lit;
319 
static TYPE type_wstring_lit;
320 
CV_SPEC cv_string = cv_none;
2 7u83 321 
 
322 
 
323 
/*
324 
    SET THE CHARACTER LITERAL TYPE
325 
 
326 
    This routine sets the type of a character literal to be t.  t must be
327 
    an integral type.  Note that only the representation type is set to t,
328 
    the semantic type is always char.
329 
*/
330 
 
6 7u83 331 
void
332 
set_char_lit(TYPE t)
2 7u83 333 
{
6 7u83 334 
	if (IS_type_integer(t)) {
335 
		INT_TYPE r = DEREF_itype(type_integer_rep(t));
336 
		INT_TYPE s = DEREF_itype(type_integer_rep(type_char));
337 
		type_char_lit = make_itype(r, s);
338 
	} else {
339 
		report(preproc_loc, ERR_pragma_char_lit(t));
340 
	}
341 
	return;
2 7u83 342 
}
343 
 
344 
 
345 
/*
346 
    TABLE OF INTEGER LITERAL SPECIFICATIONS
347 
 
348 
    The type LITERAL_INFO is used to represent an item in an integer
349 
    literal type specification.  The table int_lit_spec holds the
350 
    specifications for the various combinations of base and suffix.
351 
*/
352 
 
353 
typedef struct lit_info_tag {
6 7u83 354 
	int tag;
355 
	TYPE type;
356 
	NAT bound;
357 
	IDENTIFIER tok;
358 
	int tok_no;
359 
	int opt;
360 
	struct lit_info_tag *next;
361 
} LITERAL_INFO;
2 7u83 362 
 
6 7u83 363 
static LITERAL_INFO *int_lit_spec[BASE_NO][SUFFIX_NO] = {
364 
	{ NULL, NULL, NULL, NULL, NULL, NULL },
365 
	{ NULL, NULL, NULL, NULL, NULL, NULL },
366 
	{ NULL, NULL, NULL, NULL, NULL, NULL }
367 
};
2 7u83 368 
 
6 7u83 369 
static LITERAL_INFO *crt_int_lit = NULL;
370 
static LITERAL_INFO **ptr_int_lit = NULL;
2 7u83 371 
 
372 
 
373 
/*
374 
    TABLE OF BUILT-IN INTEGER LITERAL SPECIFICATIONS
375 
 
376 
    This table gives the possible types and built-in tokens for the
377 
    various base and suffix combinations.
378 
*/
379 
 
380 
static struct {
6 7u83 381 
	unsigned char type[6];
382 
	int tok;
383 
	LIST(TYPE)cases;
384 
} int_lit_tok[BASE_NO][SUFFIX_NO] = {
385 
	{
386 
		{ { 2, 0, 2, 2, 1, 1 }, TOK_lit_int, NULL_list(TYPE)},
387 
		{ { 0, 2, 0, 2, 0, 1 }, TOK_lit_unsigned, NULL_list(TYPE)},
388 
		{ { 0, 0, 2, 2, 1, 1 }, TOK_lit_long, NULL_list(TYPE)},
389 
		{ { 0, 0, 0, 2, 0, 1 }, TOK_lit_ulong, NULL_list(TYPE)},
390 
		{ { 0, 0, 0, 0, 2, 2 }, TOK_lit_llong, NULL_list(TYPE)},
391 
		{ { 0, 0, 0, 0, 0, 2 }, TOK_lit_ullong, NULL_list(TYPE)}
392 
	},
393 
	{
394 
		{ { 2, 2, 2, 2, 1, 1 }, TOK_lit_hex, NULL_list(TYPE)},
395 
		{ { 0, 2, 0, 2, 0, 1 }, TOK_lit_unsigned, NULL_list(TYPE)},
396 
		{ { 0, 0, 2, 2, 1, 1 }, TOK_lit_long, NULL_list(TYPE)},
397 
		{ { 0, 0, 0, 2, 0, 1 }, TOK_lit_ulong, NULL_list(TYPE)},
398 
		{ { 0, 0, 0, 0, 2, 2 }, TOK_lit_llong, NULL_list(TYPE)},
399 
		{ { 0, 0, 0, 0, 0, 2 }, TOK_lit_ullong, NULL_list(TYPE)}
400 
	},
401 
	{
402 
		{ { 2, 2, 2, 2, 1, 1 }, TOK_lit_hex, NULL_list(TYPE)},
403 
		{ { 0, 2, 0, 2, 0, 1 }, TOK_lit_unsigned, NULL_list(TYPE)},
404 
		{ { 0, 0, 2, 2, 1, 1 }, TOK_lit_long, NULL_list(TYPE)},
405 
		{ { 0, 0, 0, 2, 0, 1 }, TOK_lit_ulong, NULL_list(TYPE)},
406 
		{ { 0, 0, 0, 0, 2, 2 }, TOK_lit_llong, NULL_list(TYPE)},
407 
		{ { 0, 0, 0, 0, 0, 2 }, TOK_lit_ullong, NULL_list(TYPE)}
408 
	}
409 
};
2 7u83 410 
 
411 
 
412 
/*
413 
    INITIALISE TABLE OF INTEGER LITERAL TYPES
414 
 
415 
    This routine initialises the string and character literal types and
416 
    the table int_lit_info.  The initial values for the table are given
417 
    by the following lists of types:
418 
 
419 
	decimal:	( int, long, unsigned long ),
420 
	octal/hex:	( int, unsigned, long, unsigned long ),
421 
	U suffix:	( unsigned, unsigned long ),
422 
	L suffix:	( long, unsigned long ),
423 
	UL suffix:	( unsigned long ),
424 
	LL suffix:	( long long, unsigned long long ),
425 
	ULL suffix:	( unsigned long long ).
426 
 
427 
    Each integer literal is checked against each type in the list
428 
    indicated by the form of the literal.  If it fits into a type then
429 
    that is the type of the literal.  If it does not fit into any type
430 
    then an error is raised.  If whether it fits into a particular type
431 
    is target dependent then a literal integer type, giving the literal
432 
    value and a list of possible types, is constructed to express the
433 
    result type.
434 
 
435 
    The string and character types are:
436 
 
437 
	character:		char,
438 
	multi-character:	int,
439 
	wide character:		wchar_t,
440 
	string:			const char [n],
441 
	wide string:		const wchar_t [n].
442 
 
443 
    Variants are that characters have type int in C and that string
444 
    literals are not const in pre-ISO C++ and C.
445 
*/
446 
 
6 7u83 447 
void
448 
init_literal(void)
2 7u83 449 
{
6 7u83 450 
	int b, s;
451 
	BUILTIN_TYPE n;
452 
	OPTION opt = option(OPT_int_overflow);
453 
	ASSERT(!IS_NULL_type(type_char));
2 7u83 454 
 
6 7u83 455 
	/* String and character literal types */
456 
	type_mchar_lit = type_sint;
457 
	type_wchar_lit = type_wchar_t;
458 
	type_string_lit = type_char;
459 
	type_wstring_lit = type_wchar_t;
2 7u83 460 
#if LANGUAGE_CPP
6 7u83 461 
	set_char_lit(type_char);
462 
	set_string_qual(cv_const);
2 7u83 463 
#else
6 7u83 464 
	set_char_lit(type_sint);
465 
	set_string_qual(cv_none);
2 7u83 466 
#endif
467 
 
6 7u83 468 
	/* Set up type lists */
469 
	for (b = 0; b < BASE_NO; b++) {
470 
		for (s = 0; s < SUFFIX_NO; s++) {
471 
			LIST(TYPE)p = NULL_list(TYPE);
472 
			begin_literal(b, s);
473 
			for (n = 0; n < 6; n++) {
474 
				if (int_lit_tok[b][s].type[n] == 2) {
475 
					TYPE t = type_builtin[ntype_sint + n];
476 
					add_range_literal(NULL_exp, 1);
477 
					add_type_literal(t);
478 
					CONS_type(t, p, p);
479 
				}
480 
			}
481 
			add_range_literal(NULL_exp, 0);
482 
			add_token_literal(NULL_id, (unsigned)opt);
483 
			p = REVERSE_list(p);
484 
			int_lit_tok[b][s].cases = uniq_type_set(p);
2 7u83 485 
		}
486 
	}
487 
 
6 7u83 488 
	/* Set up string hash table */
489 
	if (string_hash_table == NULL) {
490 
		unsigned long i;
491 
		STRING *q = xmalloc_nof(STRING, HASH_STRING_SIZE);
492 
		for (i = 0; i < HASH_STRING_SIZE; i++) {
493 
			q[i] = NULL_str;
494 
		}
495 
		string_hash_table = q;
496 
	}
497 
	return;
2 7u83 498 
}
499 
 
500 
 
501 
/*
502 
    SET THE CV-QUALIFIERS FOR A STRING LITERAL
503 
 
504 
    This routine sets the string and wide string literal types to be
505 
    cv-qualified.
506 
*/
507 
 
6 7u83 508 
void
509 
set_string_qual(CV_SPEC cv)
2 7u83 510 
{
6 7u83 511 
	type_string_lit = qualify_type(type_string_lit, cv, 0);
512 
	type_wstring_lit = qualify_type(type_wstring_lit, cv, 0);
513 
	cv_string = cv;
514 
	return;
2 7u83 515 
}
516 
 
517 
 
518 
/*
519 
    BEGIN A LITERAL SPECIFICATION DEFINITION
520 
 
521 
    This routine is called to begin the specification of the integer
522 
    literals of the given base and suffix.
523 
*/
524 
 
6 7u83 525 
void
526 
begin_literal(int base, int suff)
2 7u83 527 
{
6 7u83 528 
	LITERAL_INFO **p = &(int_lit_spec[base][suff]);
529 
	*p = NULL;
530 
	ptr_int_lit = p;
531 
	crt_int_lit = NULL;
532 
	return;
2 7u83 533 
}
534 
 
535 
 
536 
/*
537 
    ADD A BOUND TO A LITERAL SPECIFICATION
538 
 
539 
    This routine is used to specify a bound in the current literal
540 
    specification.  If n is 0 then the bound matches all values, if it
541 
    is 1 then the bound matches all the values in the following type,
542 
    and if it is 2 then the bound matches all values less than or equal
543 
    to the integer literal expression e.
544 
*/
545 
 
6 7u83 546 
void
547 
add_range_literal(EXP e, int n)
2 7u83 548 
{
6 7u83 549 
	LITERAL_INFO *p = xmalloc_one(LITERAL_INFO);
550 
	p->tag = n;
551 
	if (!IS_NULL_exp(e) && IS_exp_int_lit(e)) {
552 
		p->bound = DEREF_nat(exp_int_lit_nat(e));
553 
	} else {
554 
		p->bound = small_nat[0];
555 
	}
556 
	p->type = NULL_type;
557 
	p->tok = NULL_id;
558 
	p->tok_no = -1;
559 
	p->opt = OPT_none;
560 
	p->next = NULL;
561 
	*ptr_int_lit = p;
562 
	crt_int_lit = p;
563 
	ptr_int_lit = & (p->next);
564 
	return;
2 7u83 565 
}
566 
 
567 
 
568 
/*
569 
    ADD A TYPE TO A LITERAL SPECIFICATION
570 
 
571 
    This routine specifies the type t for all values under the current
572 
    bound in the current literal specification.
573 
*/
574 
 
6 7u83 575 
void
576 
add_type_literal(TYPE t)
2 7u83 577 
{
6 7u83 578 
	NAT n;
579 
	LITERAL_INFO *p = crt_int_lit;
580 
	if (IS_type_integer(t)) {
581 
		if (!is_arg_promote(t)) {
582 
			/* Type should promote to itself */
583 
			report(preproc_loc, ERR_pragma_lit_type(t));
584 
			t = promote_type(t);
585 
		}
586 
	} else {
587 
		/* Type should be integral */
588 
		if (!IS_type_error(t)) {
589 
			report(preproc_loc, ERR_pragma_lit_type(t));
590 
		}
591 
		t = type_ulong;
2 7u83 592 
	}
6 7u83 593 
	p->type = qualify_type(t, cv_none, 0);
594 
	n = p->bound;
595 
	if (p->tag == 2) {
596 
		if (check_nat_range(t, n)!= 0) {
597 
			/* Given bound should fit into type */
598 
			report(preproc_loc, ERR_pragma_lit_range(n, t));
599 
			n = max_type_value(t, 0);
600 
		}
601 
	} else {
602 
		n = max_type_value(t, 0);
2 7u83 603 
	}
6 7u83 604 
	p->bound = n;
605 
	return;
2 7u83 606 
}
607 
 
608 
 
609 
/*
610 
    ADD A TOKEN TO A LITERAL SPECIFICATION
611 
 
612 
    This routine specifies that the token id should be used to calculate
613 
    the type for all values under the current bound in the current
614 
    literal specification.  An error with severity sev is reported.
615 
*/
616 
 
6 7u83 617 
void
618 
add_token_literal(IDENTIFIER id, unsigned sev)
2 7u83 619 
{
6 7u83 620 
	int n = -1;
621 
	LITERAL_INFO *p = crt_int_lit;
622 
	if (!IS_NULL_id(id)) {
623 
		id = resolve_token(id, "ZZ", 0);
624 
		if (!IS_NULL_id(id)) {
625 
			n = builtin_token(id);
626 
		}
627 
	}
628 
	if (p->tag == 1) {
629 
		report(preproc_loc, ERR_pragma_lit_question());
630 
		p->tag = 3;
631 
	}
632 
	p->tok = id;
633 
	p->tok_no = n;
634 
	switch (sev) {
635 
	case OPTION_ON:
636 
		p->opt = OPT_error;
637 
		break;
638 
	case OPTION_WARN:
639 
		p->opt = OPT_warning;
640 
		break;
641 
	default:
642 
		p->opt = OPT_none;
643 
		break;
644 
	}
645 
	return;
2 7u83 646 
}
647 
 
648 
 
649 
/*
650 
    FIND AN INTEGER LITERAL TYPE
651 
 
652 
    This routine finds the type of the integer constant lit specified
653 
    with base base and suffix suff.  num gives the text used to specify
654 
    the constant for the purposes of error reporting.  fit is set to
655 
    true if lit definitely fits into the result.
656 
*/
657 
 
6 7u83 658 
TYPE
659 
find_literal_type(NAT lit, int base, int suff, string num, int *fit)
2 7u83 660 
{
6 7u83 661 
	TYPE t;
662 
	int tok;
663 
	INT_TYPE it;
664 
	int big = 0;
665 
	int have_tok = 0;
666 
	int opt = OPT_error;
667 
	NAT n = small_nat[0];
668 
	IDENTIFIER tid = NULL_id;
669 
	LIST(TYPE)qt = NULL_list(TYPE);
670 
	LITERAL_INFO *pt = int_lit_spec[base][suff];
2 7u83 671 
 
6 7u83 672 
	/* Deal with calculated literals */
673 
	switch (TAG_nat(lit)) {
674 
	case nat_neg_tag:
675 
		lit = DEREF_nat(nat_neg_arg(lit));
676 
		t = find_literal_type(lit, base, suff, num, fit);
677 
		return(t);
678 
	case nat_token_tag:
679 
		t = type_sint;
680 
		*fit = 1;
681 
		return(t);
682 
	case nat_calc_tag: {
683 
		EXP e = DEREF_exp(nat_calc_value(lit));
684 
		t = DEREF_type(exp_type(e));
685 
		*fit = 1;
686 
		return(t);
2 7u83 687 
	}
688 
	}
6 7u83 689 
 
690 
	/* Deal with simple literals */
691 
	while (pt != NULL) {
692 
		int ch = 4;
693 
		TYPE s = pt->type;
694 
		switch (pt->tag) {
695 
		case 0: {
696 
			TYPE r = s;
697 
			if (IS_NULL_type(r)) {
698 
				r = type_ulong;
699 
			}
700 
			ch = check_nat_range(r, lit);
701 
			if (ch == 0) {
702 
				*fit = 1;
703 
			}
704 
			if (ch > 4) {
705 
				big = ch;
706 
			}
707 
			if (big) {
708 
				n = max_type_value(NULL_type, 0);
709 
			}
710 
			ch = big;
711 
			break;
712 
		}
713 
		case 1:
714 
			n = pt->bound;
715 
			ch = check_nat_range(s, lit);
716 
			if (ch == 0) {
717 
				*fit = 1;
718 
			}
719 
			break;
720 
		case 2:
721 
			n = pt->bound;
722 
			if (compare_nat(n, lit) >= 0) {
723 
				if (!IS_NULL_type(s))*fit = 1;
724 
				ch = 0;
725 
			}
726 
			break;
727 
		}
728 
 
729 
		if (ch == 0) {
730 
			/* lit definitely fits into bound */
731 
			if (!IS_NULL_type(s) && IS_NULL_list(qt)) {
732 
				/* No previous fit */
733 
				return(s);
734 
			}
735 
		}
736 
		if (ch <= 2) {
737 
			/* lit may fit into bound */
738 
			if (!IS_NULL_type(s)) {
739 
				if (have_tok == 0) {
740 
					INT_TYPE is =
741 
					    DEREF_itype(type_integer_rep(s));
742 
					LIST(TYPE)st =
743 
					    DEREF_list(itype_cases(is));
744 
					qt = union_type_set(qt, st);
745 
					if (ch == 0) {
746 
						have_tok = 1;
747 
					}
748 
				}
749 
			} else {
750 
				if (have_tok == 0 && !IS_NULL_id(pt->tok)) {
751 
					DESTROY_list(qt, SIZE_type);
752 
					tok = int_lit_tok[base][suff].tok;
753 
					if (pt->tok_no == tok) {
754 
						qt = int_lit_tok[base][suff].cases;
755 
					} else if (suff < SUFFIX_LL) {
756 
						qt = all_prom_types;
757 
					} else {
758 
						qt = all_llong_types;
759 
					}
760 
					have_tok = 2;
761 
				}
762 
				break;
763 
			}
764 
		}
765 
		if (ch > 4) {
766 
			big = ch;
767 
		}
768 
		pt = pt->next;
2 7u83 769 
	}
770 
 
6 7u83 771 
	/* Tokenised result */
772 
	if (have_tok != 2) {
773 
		/* Find list of possible types */
774 
		if (IS_NULL_list(qt)) {
775 
			qt = int_lit_tok[base][suff].cases;
776 
		} else {
777 
			qt = REVERSE_list(qt);
778 
			qt = uniq_type_set(qt);
2 7u83 779 
		}
780 
	}
6 7u83 781 
	if (pt) {
782 
		/* Get token information from table */
783 
		tid = pt->tok;
784 
		opt = pt->opt;
2 7u83 785 
	}
6 7u83 786 
	if (num && !(*fit)) {
787 
		/* Report error if necessary */
788 
		ERROR err = ERR_lex_icon_large(num, n);
789 
		err = set_severity(err, opt, 0);
790 
		if (!IS_NULL_err(err)) {
791 
			report(crt_loc, err);
2 7u83 792 
		}
793 
	}
6 7u83 794 
	if (LENGTH_list(qt) == 1) {
795 
		/* Only one possible case */
796 
		t = DEREF_type(HEAD_list(qt));
797 
		DESTROY_list(qt, SIZE_type);
798 
		return(t);
2 7u83 799 
	}
6 7u83 800 
	tok = int_lit_tok[base][suff].tok;
801 
	MAKE_itype_literal(NULL_type, qt, lit, tok, base, suff, tid, it);
802 
	t = promote_itype(it, it);
803 
	return(t);
2 7u83 804 
}
805 
 
806 
 
807 
/*
808 
    ANALYSE AN INTEGER OR FLOATING LITERAL
809 
 
810 
    This routine analyses the integer or floating literal given by the
811 
    string str, constructing the corresponding expression.  The location
812 
    given by ptok is assigned with lex_integer_Hexp or lex_floating_Hexp
813 
    depending on the form of the literal.  Note that str can be an area
814 
    of read-only memory for integer literals, but not for floating
815 
    literals.
816 
*/
817 
 
6 7u83 818 
EXP
819 
make_literal_exp(string str, int *ptok, int force)
2 7u83 820 
{
6 7u83 821 
	EXP e;
822 
	string r;
823 
	int err = 0;
824 
	int flt = 0;
825 
	string s = str;
826 
	unsigned base = 10;
827 
	string dot_posn = NULL;
828 
	string exp_posn = NULL;
829 
	int form = BASE_DECIMAL;
2 7u83 830 
 
6 7u83 831 
	/* Check small literals */
832 
	character c1 = s[0];
833 
	character c2 = 0;
834 
	if (c1) {
835 
		c2 = s[1];
836 
	}
837 
	if (c2 == 0 && (c1 >= char_zero && c1 <= char_nine)) {
838 
		unsigned etag = exp_int_lit_tag;
839 
		int n = (int)digit_values[c1];
840 
		NAT lit = small_nat[n];
841 
		if (IS_NULL_nat(lit)) {
842 
			lit = make_small_nat(n);
843 
		}
844 
		if (n == 0) {
845 
			etag = exp_null_tag;
846 
		}
847 
		MAKE_exp_int_lit(type_sint, lit, etag, e);
848 
		*ptok = lex_integer_Hexp;
849 
		return(e);
850 
	}
2 7u83 851 
 
6 7u83 852 
	if (c1 == char_zero && (c2 == char_x || c2 == char_X)) {
853 
		/* Hexadecimal integer */
854 
		base = 16;
855 
		form = BASE_HEXADECIMAL;
856 
		r = s + 2;
857 
		s = check_digits(r, base);
858 
		if (s == r) {
859 
			err = 1;
860 
		}
2 7u83 861 
	} else {
6 7u83 862 
		if (c1 == char_dot) {
863 
			/* Fractional component of floating literal */
864 
			dot_posn = s;
865 
			r = s + 1;
866 
			s = check_digits(r, base);
867 
			if (s == r) {
868 
				err = 1;
869 
			}
870 
			flt = 1;
871 
		} else {
872 
			/* Sequence of decimal digits */
873 
			r = s;
874 
			s = check_digits(r, base);
875 
			if (s == r) {
876 
				if (c1 == char_plus || c1 == char_minus) {
877 
					/* Extension to handle signs */
878 
					e = make_literal_exp(str + 1, ptok,
879 
							     force);
880 
					if (c1 == char_minus) {
881 
						e = make_uminus_exp(lex_minus,
882 
								    e);
883 
					}
884 
					return(e);
885 
				}
886 
				err = 1;
887 
			}
888 
			if (s[0] == char_dot) {
889 
				/* Fractional component of floating literal */
890 
				dot_posn = s;
891 
				s = check_digits(s + 1, base);
892 
				flt = 1;
893 
			}
2 7u83 894 
		}
6 7u83 895 
		exp_posn = s;
896 
		c2 = s[0];
897 
		if (c2 == char_e || c2 == char_E) {
898 
			/* Exponent component of floating literal */
899 
			c2 = s[1];
900 
			if (c2 == char_plus || c2 == char_minus) {
901 
				s++;
902 
			}
903 
			r = s + 1;
904 
			s = check_digits(r, base);
905 
			if (s == r) {
906 
				err = 1;
907 
			}
908 
			flt = 1;
909 
		}
910 
		if (c1 == char_zero && !flt) {
911 
			/* Octal integer */
912 
			base = 8;
913 
			form = BASE_OCTAL;
914 
			r = check_digits(str, base);
915 
			if (r != s) {
916 
				/* Digits contain 8 or 9 */
917 
				report(crt_loc, ERR_lex_icon_octal(str));
918 
			}
919 
		}
2 7u83 920 
	}
921 
 
6 7u83 922 
	if (flt) {
923 
		/* Floating literals */
924 
		int zero;
925 
		NAT expon;
926 
		character ep;
927 
		string frac_part;
928 
		string int_part = str;
929 
		string suff_posn = s;
930 
		unsigned trail_zero = 0;
931 
		FLOAT lit = NULL_flt;
932 
		TYPE t = type_double;
2 7u83 933 
 
6 7u83 934 
		/* Check float suffix */
935 
		c1 = s[0];
936 
		if (c1 == char_f || c1 == char_F) {
937 
			/* Suffix F */
938 
			t = type_float;
939 
			s++;
940 
			c1 = s[0];
941 
		} else if (c1 == char_l || c1 == char_L) {
942 
			/* Suffix L */
943 
			t = type_ldouble;
944 
			s++;
945 
			c1 = s[0];
946 
		}
2 7u83 947 
 
6 7u83 948 
		/* Check for end of number */
949 
		if (c1 || err) {
950 
			report(crt_loc, ERR_lex_literal_bad(str));
951 
		}
2 7u83 952 
 
6 7u83 953 
		/* Find number components (involves writing to s)  */
954 
		while (int_part[0] == char_zero) {
955 
			/* Remove initial zeros */
956 
			int_part++;
2 7u83 957 
		}
6 7u83 958 
		if (dot_posn) {
959 
			dot_posn[0] = 0;
960 
			if (int_part == dot_posn) {
961 
				int_part = small_number[0];
962 
			}
963 
			frac_part = dot_posn + 1;
964 
			if (frac_part == exp_posn) {
965 
				frac_part = small_number[0];
966 
			} else {
967 
				/* Remove trailing zeros */
968 
				string frac_zero = exp_posn - 1;
969 
				while (frac_zero[0] == char_zero) {
970 
					frac_zero[0] = 0;
971 
					frac_zero--;
972 
					trail_zero++;
973 
				}
974 
				if (frac_zero == dot_posn) {
975 
					frac_part = small_number[0];
976 
				}
977 
			}
978 
		} else {
979 
			if (int_part == exp_posn) {
980 
				int_part = small_number[0];
981 
			}
982 
			frac_part = small_number[0];
2 7u83 983 
		}
6 7u83 984 
		ep = exp_posn[0];
985 
		exp_posn[0] = 0;
986 
		if (ep == char_e || ep == char_E) {
987 
			/* Evaluate exponent */
988 
			r = exp_posn + 1;
989 
			c2 = r[0];
990 
			if (c2 == char_minus || c2 == char_plus) {
991 
				r++;
992 
			}
993 
			expon = eval_digits(r, suff_posn, base);
994 
			if (c2 == char_minus) {
995 
				expon = negate_nat(expon);
996 
			}
997 
			zero = is_zero_nat(expon);
998 
		} else {
999 
			expon = small_nat[0];
1000 
			zero = 1;
1001 
		}
1002 
		if (zero && ustreq(frac_part, small_number[0])) {
1003 
			int i;
1004 
			for (i = 0; i < SMALL_FLT_SIZE; i++) {
1005 
				if (ustreq(int_part, small_number[i])) {
1006 
					lit = get_float(t, i);
1007 
					break;
1008 
				}
1009 
			}
1010 
		}
1011 
		if (IS_NULL_flt(lit)) {
1012 
			int_part = xustrcpy(int_part);
1013 
			frac_part = xustrcpy(frac_part);
1014 
		}
1015 
		if (trail_zero) {
1016 
			/* Restore trailing zeros */
1017 
			r = exp_posn - 1;
1018 
			do {
1019 
				r[0] = char_zero;
1020 
				r--;
1021 
				trail_zero--;
1022 
			} while (trail_zero);
1023 
		}
1024 
		if (dot_posn) {
1025 
			dot_posn[0] = char_dot;
1026 
		}
1027 
		exp_posn[0] = ep;
2 7u83 1028 
 
6 7u83 1029 
		/* Construct result - type is as per suffix */
1030 
		if (IS_NULL_flt(lit)) {
1031 
			MAKE_flt_simple(int_part, frac_part, expon, lit);
1032 
		}
1033 
		MAKE_exp_float_lit(t, lit, e);
1034 
		*ptok = lex_floating_Hexp;
2 7u83 1035 
 
6 7u83 1036 
	} else {
1037 
		/* Integer literals */
1038 
		TYPE t;
1039 
		NAT lit;
1040 
		int ls = 0;
1041 
		int us = 0;
1042 
		int fit = 0;
2 7u83 1043 
 
6 7u83 1044 
		/* Find integer value */
1045 
		r = str;
1046 
		if (form == BASE_HEXADECIMAL) {
1047 
			r += 2;
1048 
		}
1049 
		lit = eval_digits(r, s, base);
2 7u83 1050 
 
6 7u83 1051 
		/* Check integer suffix */
1052 
		c1 = s[0];
1053 
		if (c1 == char_u || c1 == char_U) {
1054 
			us = 1;
1055 
			s++;
1056 
			c1 = s[0];
1057 
		}
1058 
		if (c1 == char_l || c1 == char_L) {
1059 
			ls = 1;
1060 
			if (s[1] == c1 && basetype_info[ntype_sllong].key) {
1061 
				report(crt_loc, ERR_lex_icon_llong(str));
1062 
				ls = 2;
1063 
				s++;
1064 
			}
1065 
			s++;
1066 
			c1 = s[0];
1067 
		} else {
1068 
			/* Map 'int' to 'long' in '#if' expressions */
1069 
			if (in_hash_if_exp) {
1070 
				ls = 1;
1071 
			}
1072 
		}
1073 
		if (us == 0 && (c1 == char_u || c1 == char_U)) {
1074 
			us = 1;
1075 
			s++;
1076 
			c1 = s[0];
1077 
		}
2 7u83 1078 
 
6 7u83 1079 
		/* Check for end of number */
1080 
		if (c1 || err) {
1081 
			report(crt_loc, ERR_lex_literal_bad(str));
1082 
		}
2 7u83 1083 
 
6 7u83 1084 
		/* Find literal type */
1085 
		if (force) {
1086 
			t = type_ulong;
1087 
			fit = 1;
1088 
		} else {
1089 
			int suff = SUFFIX(us, ls);
1090 
			t = find_literal_type(lit, form, suff, str, &fit);
1091 
		}
1092 
		MAKE_exp_int_lit(t, lit, exp_int_lit_tag, e);
1093 
		if (!fit) {
1094 
			/* Force result to be a calculated value */
1095 
			MAKE_exp_cast(t, CONV_INT_INT, e, e);
1096 
			MAKE_nat_calc(e, lit);
1097 
			MAKE_exp_int_lit(t, lit, exp_int_lit_tag, e);
1098 
		}
1099 
		*ptok = lex_integer_Hexp;
2 7u83 1100 
	}
6 7u83 1101 
	return(e);
2 7u83 1102 
}
1103 
 
1104 
 
1105 
/*
1106 
    IS A FLOATING LITERAL ZERO?
1107 
 
1108 
    This routine checks whether the floating point literal f is zero.
1109 
*/
1110 
 
6 7u83 1111 
int
1112 
is_zero_float(FLOAT f)
2 7u83 1113 
{
6 7u83 1114 
	string s;
1115 
	character c;
1116 
	s = DEREF_string(flt_simple_int_part(f));
1117 
	while (c = *(s++), c != 0) {
1118 
		if (c != char_zero) {
1119 
			return(0);
1120 
		}
1121 
	}
1122 
	s = DEREF_string(flt_simple_frac_part(f));
1123 
	while (c = *(s++), c != 0) {
1124 
		if (c != char_zero) {
1125 
			return(0);
1126 
		}
1127 
	}
1128 
	return(1);
2 7u83 1129 
}
1130 
 
1131 
 
1132 
/*
1133 
    ARE TWO FLOATING LITERALS EQUAL?
1134 
 
1135 
    This routine checks whether the floating point literals f and g are
1136 
    equal.  Note that this is equality of representation rather than
1137 
    equality of the underlying numbers.
1138 
*/
1139 
 
6 7u83 1140 
int
1141 
eq_float_lit(FLOAT f, FLOAT g)
2 7u83 1142 
{
6 7u83 1143 
	NAT ef, eg;
1144 
	ulong nf, ng;
1145 
	string af, ag;
1146 
	string bf, bg;
1147 
	if (EQ_flt(f, g)) {
1148 
		return(1);
1149 
	}
1150 
	DECONS_flt_simple(nf, af, bf, ef, f);
1151 
	DECONS_flt_simple(ng, ag, bg, eg, g);
1152 
	if (!ustreq(af, ag)) {
1153 
		return(0);
1154 
	}
1155 
	if (!ustreq(bf, bg)) {
1156 
		return(0);
1157 
	}
1158 
	if (compare_nat(ef, eg)!= 0) {
1159 
		return(0);
1160 
	}
1161 
	if (nf == LINK_NONE) {
1162 
		COPY_ulong(flt_tok(f), ng);
1163 
	}
1164 
	if (ng == LINK_NONE) {
1165 
		COPY_ulong(flt_tok(g), nf);
1166 
	}
1167 
	return(1);
2 7u83 1168 
}
1169 
 
1170 
 
1171 
/*
1172 
    DEFAULT ROUNDING MODE
1173 
 
1174 
    This variable gives the default rounding mode used for converting
1175 
    floating point expressions to integers.
1176 
*/
1177 
 
6 7u83 1178 
RMODE crt_round_mode = rmode_to_zero;
2 7u83 1179 
 
1180 
 
1181 
/*
1182 
    ROUND A FLOATING POINT LITERAL
1183 
 
1184 
    This routine rounds the floating point literal f to an integer
1185 
    literal by the rounding mode corresponding to mode.  The null integer
1186 
    literal is returned to indicate a target dependent literal.  The
1187 
    range of values in which the result is target independent is actually
1188 
    rather small - it is given by FLT_DIG.
1189 
*/
1190 
 
6 7u83 1191 
NAT
1192 
round_float_lit(FLOAT f, RMODE mode)
2 7u83 1193 
{
6 7u83 1194 
	NAT res;
1195 
	unsigned base = 10;
1196 
	unsigned long i, j, n;
1197 
	unsigned long res_len;
1198 
	unsigned long pre_len;
1199 
	unsigned long exp_val;
1200 
	character result[100];
2 7u83 1201 
 
6 7u83 1202 
	/* Decompose simple literal */
1203 
	string int_part = DEREF_string(flt_simple_int_part(f));
1204 
	string frac_part = DEREF_string(flt_simple_frac_part(f));
1205 
	NAT expon = DEREF_nat(flt_simple_exponent(f));
2 7u83 1206 
 
6 7u83 1207 
	/* Find component lengths */
1208 
	unsigned long int_len = (unsigned long)ustrlen(int_part);
1209 
	unsigned long frac_len = (unsigned long)ustrlen(frac_part);
2 7u83 1210 
 
6 7u83 1211 
	/* Allow for initial zeros */
1212 
	while (int_part[0] == char_zero) {
1213 
		int_part++;
1214 
		int_len--;
1215 
	}
2 7u83 1216 
 
6 7u83 1217 
	/* Allow for exponent */
1218 
	if (IS_nat_neg(expon)) {
1219 
		expon = DEREF_nat(nat_neg_arg(expon));
1220 
		exp_val = get_nat_value(expon);
1221 
		if (exp_val > int_len) {
1222 
			res_len = 0;
1223 
			pre_len = exp_val - int_len;
1224 
		} else {
1225 
			res_len = int_len - exp_val;
1226 
			pre_len = 0;
1227 
		}
2 7u83 1228 
	} else {
6 7u83 1229 
		exp_val = get_nat_value(expon);
1230 
		res_len = int_len + exp_val;
1231 
		pre_len = 0;
2 7u83 1232 
	}
1233 
 
6 7u83 1234 
	/* Allow for initial zeros in fractional part */
1235 
	if (int_part[0] == 0) {
1236 
		while (frac_part[0] == char_zero) {
1237 
			frac_part++;
1238 
			frac_len--;
1239 
			if (res_len == 0) {
1240 
				pre_len++;
1241 
			} else {
1242 
				res_len--;
1243 
			}
1244 
		}
1245 
		if (frac_part[0] == 0) {
1246 
			/* Zero floating literal */
1247 
			res = small_nat[0];
1248 
			return(res);
1249 
		}
2 7u83 1250 
	}
6 7u83 1251 
 
1252 
	/* Extreme values are target dependent */
1253 
	if (pre_len > 6) {
1254 
		return(NULL_nat);
2 7u83 1255 
	}
6 7u83 1256 
	if (res_len > 6) {
1257 
		return(NULL_nat);
1258 
	}
1259 
	if (exp_val == EXTENDED_MAX) {
1260 
		return(NULL_nat);
1261 
	}
2 7u83 1262 
 
6 7u83 1263 
	/* Construct integer string */
1264 
	j = 0;
1265 
	n = res_len;
1266 
	for (i = 0; i < pre_len; i++) {
1267 
		if (j < n) {
1268 
			result[j] = char_zero;
1269 
			j++;
1270 
		}
2 7u83 1271 
	}
6 7u83 1272 
	for (i = 0; i < int_len; i++) {
1273 
		if (j < n) {
1274 
			result[j] = int_part[i];
1275 
			j++;
1276 
		}
2 7u83 1277 
	}
6 7u83 1278 
	for (i = 0; i < frac_len; i++) {
1279 
		if (j < n) {
1280 
			result[j] = frac_part[i];
1281 
			j++;
1282 
		}
2 7u83 1283 
	}
6 7u83 1284 
	for (; j < n; j++) {
1285 
		result[j] = char_zero;
1286 
	}
1287 
	result[n] = 0;
2 7u83 1288 
 
6 7u83 1289 
	/* Calculate the result */
1290 
	res = eval_digits(result, result + res_len, base);
1291 
	UNUSED(mode);
1292 
	return(res);
2 7u83 1293 
}
1294 
 
1295 
 
1296 
/*
1297 
    EVALUATE A UNICODE CHARACTER
1298 
 
1299 
    This routine evaluates the unicode character with prefix c, consisting
1300 
    of n hex digits, given by ps.  ps is advanced to the position following
1301 
    the hex digits.
1302 
*/
1303 
 
6 7u83 1304 
unsigned long
1305 
eval_unicode(int c, unsigned n, int *pc, string *ps, ERROR *err)
2 7u83 1306 
{
6 7u83 1307 
	string r = *ps;
1308 
	unsigned long u;
1309 
	unsigned base = 16;
1310 
	string s = check_digits(r, base);
1311 
	unsigned m = (unsigned)(s - r);
1312 
	if (m < n) {
1313 
		add_error(err, ERR_lex_charset_len(c, n));
1314 
	} else {
1315 
		s = r + n;
1316 
	}
1317 
	*ps = s;
1318 
	u = eval_char_digits(r, s, base);
1319 
	add_error(err, ERR_lex_charset_replace(u));
1320 
	if (u < 0x20 || (u >= 0x7f && u <= 0x9f) || is_legal_char(u)) {
1321 
		add_error(err, ERR_lex_charset_bad(u));
1322 
		*pc = CHAR_SIMPLE;
1323 
	} else {
1324 
		if (u <= (unsigned long)0xffff) {
1325 
			*pc = CHAR_UNI4;
1326 
		}
1327 
	}
1328 
	return(u);
2 7u83 1329 
}
1330 
 
1331 
 
1332 
/*
1333 
    GET A MULTI-BYTE CHARACTER FROM A STRING
1334 
 
1335 
    This routine returns the multi-byte character pointed to by the
1336 
    string s.  It assigns the character type to pc.
1337 
*/
1338 
 
6 7u83 1339 
unsigned long
1340 
get_multi_char(string s, int *pc)
2 7u83 1341 
{
6 7u83 1342 
	int i;
1343 
	unsigned long n = 0;
1344 
	for (i = MULTI_WIDTH - 1; i >= 1; i--) {
1345 
		n = (n << 8) + (unsigned long)s[i];
1346 
	}
1347 
	*pc = (int)s[0];
1348 
	return(n);
2 7u83 1349 
}
1350 
 
1351 
 
1352 
/*
1353 
    ADD A MULTI-BYTE CHARACTER TO A STRING
1354 
 
1355 
    This routine adds the multi-byte character n of type ch to the
1356 
    string s.  A multi-byte character is represented by 5 characters.
1357 
    The first is a key describing how the character was described (a
1358 
    simple character, a hex or octal escape sequence, a unicode
1359 
    character etc.).  The next four characters give the character value.
1360 
*/
1361 
 
6 7u83 1362 
void
1363 
add_multi_char(string s, unsigned long n, int ch)
2 7u83 1364 
{
6 7u83 1365 
	int i;
1366 
	s[0] = (character)ch;
1367 
	for (i = 1; i < MULTI_WIDTH; i++) {
1368 
		s[i] = (character)(n & 0xff);
1369 
		n >>= 8;
1370 
	}
1371 
	if (n) {
1372 
		report(crt_loc, ERR_lex_ccon_large());
1373 
	}
1374 
	return;
2 7u83 1375 
}
1376 
 
1377 
 
1378 
/*
1379 
    CREATE A MULTI-BYTE STRING
1380 
 
1381 
    This routine creates a multi-byte string of length n in s from the
1382 
    string t of kind k.
1383 
*/
1384 
 
6 7u83 1385 
static void
1386 
make_multi_string(string s, string t, unsigned long n, unsigned k)
2 7u83 1387 
{
6 7u83 1388 
	if (k & STRING_MULTI) {
1389 
		n *= MULTI_WIDTH;
1390 
		xumemcpy(s, t, (gen_size)n);
1391 
	} else {
1392 
		unsigned long i;
1393 
		for (i = 0; i < n; i++) {
1394 
			add_multi_char(s, (unsigned long)*t, CHAR_SIMPLE);
1395 
			s += MULTI_WIDTH;
1396 
			t++;
1397 
		}
2 7u83 1398 
	}
6 7u83 1399 
	return;
2 7u83 1400 
}
1401 
 
1402 
 
1403 
/*
1404 
    GET A MULTIBYTE CHARACTER FROM A STRING
1405 
 
1406 
    This routine reads a multibyte character from the string s (which
1407 
    ends at se).  The value (as a wide character) is assigned to pc with
1408 
    the new value of s being returned.  Note that this routine is not
1409 
    required in, for example, check_digits because the representation
1410 
    of a simple single byte character as a multibyte character comprises
1411 
    that single byte.
1412 
*/
1413 
 
1414 
#if FS_MULTIBYTE
1415 
 
6 7u83 1416 
static string
1417 
get_multibyte(string s, string se, unsigned long *pc)
2 7u83 1418 
{
6 7u83 1419 
	wchar_t c;
1420 
	int n = mbtowc(&c, s, (size_t)(se - s));
1421 
	if (n > 0) {
1422 
		/* Valid multibyte character */
1423 
		*pc = (unsigned long)c;
1424 
		s += n;
1425 
	} else if (n == 0) {
1426 
		/* Null character */
1427 
		*pc = 0;
1428 
		s++;
1429 
	} else {
1430 
		/* Invalid multibyte character */
1431 
		report(crt_loc, ERR_lex_ccon_multibyte());
1432 
		*pc = (unsigned long)*(s++);
1433 
	}
1434 
	return(s);
2 7u83 1435 
}
1436 
 
1437 
#endif
1438 
 
1439 
 
1440 
/*
1441 
    ANALYSE A STRING OR CHARACTER LITERAL
1442 
 
1443 
    This routine analyses the string or character literal given by the
6 7u83 1444 
    string s (which ends at se).  Only characters in the range [0, 0xff]
2 7u83 1445 
    are assumed to be valid. Note that this is the routine which should
1446 
    do the mapping from the source character set to the execution
1447 
    character set (translation phase 5), however this is deferred until
1448 
    the string output routines.
1449 
*/
1450 
 
6 7u83 1451 
STRING
1452 
new_string_lit(string s, string se, int lex)
2 7u83 1453 
{
6 7u83 1454 
	STRING res;
1455 
	STRING prev;
1456 
	int multi = 0;
1457 
	int overflow = 0;
1458 
	unsigned long len = 0;
1459 
	unsigned kind = STRING_NONE;
2 7u83 1460 
#if FS_MULTIBYTE
6 7u83 1461 
	int multibyte = allow_multibyte;
2 7u83 1462 
#endif
6 7u83 1463 
	gen_size sz = (gen_size)(se - s) + 1;
1464 
	string str = xustr(sz);
2 7u83 1465 
 
6 7u83 1466 
	/* Find string type */
1467 
	switch (lex) {
1468 
	case lex_char_Hlit:
1469 
	case lex_char_Hexp:
1470 
		kind = STRING_CHAR;
1471 
		break;
1472 
	case lex_wchar_Hlit:
1473 
	case lex_wchar_Hexp:
1474 
		kind = (STRING_WIDE | STRING_CHAR);
1475 
		break;
1476 
	case lex_string_Hlit:
1477 
	case lex_string_Hexp:
1478 
		kind = STRING_NONE;
1479 
		break;
1480 
	case lex_wstring_Hlit:
1481 
	case lex_wstring_Hexp:
1482 
		kind = STRING_WIDE;
1483 
		break;
2 7u83 1484 
	}
6 7u83 1485 
	if (do_string) {
1486 
		dump_string_lit(s, se, kind);
2 7u83 1487 
	}
1488 
 
6 7u83 1489 
	/* Scan string replacing escape sequences */
1490 
	while (s != se) {
1491 
		unsigned long c;
1492 
		int ch = CHAR_SIMPLE;
2 7u83 1493 
#if FS_MULTIBYTE
6 7u83 1494 
		if (multibyte) {
1495 
			s = get_multibyte(s, se, &c);
1496 
		} else {
1497 
			c = (unsigned long)*(s++);
1498 
		}
2 7u83 1499 
#else
6 7u83 1500 
		c = (unsigned long)*(s++);
2 7u83 1501 
#endif
6 7u83 1502 
		if (c == char_backslash) {
1503 
			if (s != se) {
1504 
				/* Unterminated string literals already
1505 
				 * reported */
1506 
				character e = NONE;
2 7u83 1507 
#if FS_MULTIBYTE
6 7u83 1508 
				if (multibyte) {
1509 
					s = get_multibyte(s, se, &c);
1510 
				} else {
1511 
					c = (unsigned long)*(s++);
1512 
				}
2 7u83 1513 
#else
6 7u83 1514 
				c = (unsigned long)*(s++);
2 7u83 1515 
#endif
6 7u83 1516 
				if (c < NO_CHAR) {
1517 
					e = escape_sequences[c];
1518 
				}
1519 
				switch (e) {
2 7u83 1520 
 
6 7u83 1521 
				case OCTE: {
1522 
					/* Octal escape sequences */
1523 
					unsigned base = 8;
1524 
					string r = s - 1;
1525 
					s = check_digits(r, base);
1526 
					if (s > r + 3) {
1527 
						s = r + 3;
1528 
					}
1529 
					c = eval_char_digits(r, s, base);
1530 
					ch = CHAR_OCTAL;
1531 
					break;
1532 
				}
2 7u83 1533 
 
6 7u83 1534 
				case HEXE: {
1535 
					/* Hexadecimal escape sequences */
1536 
					unsigned base = 16;
1537 
					string r = s;
1538 
					s = check_digits(r, base);
1539 
					if (s == r) {
1540 
						int i = (int)c;
1541 
						report(crt_loc,
1542 
						       ERR_lex_ccon_hex(i));
1543 
					} else {
1544 
						c = eval_char_digits(r, s,
1545 
								     base);
1546 
					}
1547 
					ch = CHAR_HEX;
1548 
					break;
1549 
				}
2 7u83 1550 
 
6 7u83 1551 
				case UNI4: {
1552 
					/* Short unicode escape sequences */
1553 
					if (allow_unicodes) {
1554 
						string r = s;
1555 
						unsigned d = 4;
1556 
						ERROR err = NULL_err;
1557 
						c = eval_unicode(char_u, d, &ch,
1558 
								 &r, &err);
1559 
						if (!IS_NULL_err(err)) {
1560 
							report(crt_loc, err);
1561 
						}
1562 
						ch = CHAR_UNI4;
1563 
						s = r;
1564 
						break;
1565 
					}
1566 
					goto illegal_lab;
1567 
				}
2 7u83 1568 
 
6 7u83 1569 
				case UNI8: {
1570 
					/* Long unicode escape sequences */
1571 
					if (allow_unicodes) {
1572 
						string r = s;
1573 
						unsigned d = 8;
1574 
						ERROR err = NULL_err;
1575 
						c = eval_unicode(char_U, d, &ch,
1576 
								 &r, &err);
1577 
						if (!IS_NULL_err(err)) {
1578 
							report(crt_loc, err);
1579 
						}
1580 
						ch = CHAR_UNI8;
1581 
						s = r;
1582 
						break;
1583 
					}
1584 
					goto illegal_lab;
1585 
				}
2 7u83 1586 
 
6 7u83 1587 
				case NONE:
1588 
illegal_lab: {
1589 
					/* Illegal escape sequences */
1590 
		     			int i = (int)c;
1591 
					report(crt_loc, ERR_lex_ccon_escape(i));
1592 
					break;
1593 
	     }
2 7u83 1594 
 
6 7u83 1595 
				default:
1596 
					/* Simple escape sequences */
1597 
					c = (unsigned long)e;
1598 
					break;
1599 
				}
1600 
			}
2 7u83 1601 
		}
6 7u83 1602 
		if ((ch != CHAR_SIMPLE || c >= 256) && !multi) {
1603 
			/* Convert to multi-character format */
1604 
			string a;
1605 
			sz *= MULTI_WIDTH;
1606 
			a = xustr(sz);
1607 
			make_multi_string(a, str, len, kind);
1608 
			if (len) {
1609 
				len *= MULTI_WIDTH;
1610 
				if (len == 0) {
1611 
					overflow = 1;
1612 
				}
1613 
			}
1614 
			if (c >= 256) {
1615 
				/* Mark fat strings */
1616 
				if (!(kind & STRING_WIDE)) {
1617 
					if (ch == CHAR_UNI4 ||
1618 
					    ch == CHAR_UNI8) {
1619 
						/* EMPTY */
1620 
					} else {
1621 
						report(crt_loc,
1622 
						       ERR_lex_ccon_large());
1623 
					}
1624 
				}
1625 
				kind |= STRING_FAT;
1626 
			}
1627 
			kind |= STRING_MULTI;
1628 
			multi = 1;
1629 
			str = a;
2 7u83 1630 
		}
6 7u83 1631 
		if (multi) {
1632 
			add_multi_char(str + len, c, ch);
1633 
			len += MULTI_WIDTH;
1634 
		} else {
1635 
			str[len++] = (character)c;
1636 
		}
1637 
		if (len == 0) {
1638 
			overflow = 1;
1639 
		}
2 7u83 1640 
	}
6 7u83 1641 
	if (multi) {
1642 
		add_multi_char(str + len, (unsigned long)0, CHAR_OCTAL);
1643 
		len /= MULTI_WIDTH;
2 7u83 1644 
	} else {
6 7u83 1645 
		str[len] = 0;
2 7u83 1646 
	}
6 7u83 1647 
	if (overflow) {
1648 
		len = ULONG_MAX;
2 7u83 1649 
	}
6 7u83 1650 
	if (!check_value(OPT_VAL_string_length, len)) {
1651 
		len = option_value(OPT_VAL_string_length);
1652 
		if (multi) {
1653 
			unsigned long n = MULTI_WIDTH * len;
1654 
			add_multi_char(str + n, (unsigned long)0, CHAR_OCTAL);
1655 
		} else {
1656 
			str[len] = 0;
1657 
		}
1658 
	}
1659 
	MAKE_str_simple(len, str, kind, res);
1660 
	prev = share_string_lit(res);
1661 
	if (!EQ_str(prev, res)) {
1662 
		/* Share string literals */
1663 
		unsigned long v;
1664 
		DESTROY_str_simple(destroy, res, len, str, kind, v, res);
1665 
		xufree(str, sz);
1666 
		UNUSED(res);
1667 
		UNUSED(len);
1668 
		UNUSED(kind);
1669 
		UNUSED(v);
1670 
		res = prev;
1671 
	}
1672 
	return(res);
2 7u83 1673 
}
1674 
 
1675 
 
1676 
/*
1677 
    ARE TWO STRINGS EQUAL?
1678 
 
1679 
    This routine checks whether the string literals s and t are equal.
1680 
*/
1681 
 
6 7u83 1682 
int
1683 
eq_string_lit(STRING s, STRING t)
2 7u83 1684 
{
6 7u83 1685 
	string as, at;
1686 
	unsigned ks, kt;
1687 
	unsigned long ns, nt;
1688 
	if (EQ_str(s, t)) {
1689 
		return(1);
1690 
	}
1691 
	ks = DEREF_unsigned(str_simple_kind(s));
1692 
	kt = DEREF_unsigned(str_simple_kind(t));
1693 
	ns = DEREF_ulong(str_simple_len(s));
1694 
	nt = DEREF_ulong(str_simple_len(t));
1695 
	if (ks == kt && ns == nt) {
1696 
		as = DEREF_string(str_simple_text(s));
1697 
		at = DEREF_string(str_simple_text(t));
1698 
		if (as == at) {
1699 
			return(1);
1700 
		}
1701 
		if (ks & STRING_MULTI) {
1702 
			ns *= MULTI_WIDTH;
1703 
		}
1704 
		if (xumemcmp(as, at, (gen_size)ns) == 0) {
1705 
			return(1);
1706 
		}
1707 
	}
1708 
	return(0);
2 7u83 1709 
}
1710 
 
1711 
 
1712 
/*
1713 
    CONCATENATE TWO STRING LITERALS
1714 
 
1715 
    This routine concatenates the string literals s and t.
1716 
*/
1717 
 
6 7u83 1718 
STRING
1719 
concat_string_lit(STRING s, STRING t)
2 7u83 1720 
{
6 7u83 1721 
	string c;
1722 
	STRING res;
1723 
	STRING prev;
1724 
	unsigned kc;
1725 
	gen_size sz;
1726 
	unsigned long nc;
1727 
	string a = DEREF_string(str_simple_text(s));
1728 
	string b = DEREF_string(str_simple_text(t));
1729 
	unsigned ka = DEREF_unsigned(str_simple_kind(s));
1730 
	unsigned kb = DEREF_unsigned(str_simple_kind(t));
1731 
	unsigned long na = DEREF_ulong(str_simple_len(s));
1732 
	unsigned long nb = DEREF_ulong(str_simple_len(t));
2 7u83 1733 
 
6 7u83 1734 
	/* Form the result literal */
1735 
	if (na == 0) {
1736 
		return(t);
1737 
	}
1738 
	if (nb == 0) {
1739 
		return(s);
1740 
	}
1741 
	nc = na + nb;
1742 
	if (nc < na || nc < nb) {
1743 
		nc = ULONG_MAX;
1744 
	}
1745 
	if (!check_value(OPT_VAL_string_length, nc)) {
1746 
		nc = option_value(OPT_VAL_string_length);
1747 
		nb = nc - na;
1748 
	}
1749 
	kc = (ka | kb);
1750 
	if (kc & STRING_MULTI) {
1751 
		/* Multi-byte strings */
1752 
		unsigned long sa = MULTI_WIDTH * na;
1753 
		unsigned long sc = MULTI_WIDTH * nc;
1754 
		sz = (gen_size)(sc + MULTI_WIDTH);
1755 
		c = xustr(sz);
1756 
		make_multi_string(c, a, na, ka);
1757 
		make_multi_string(c + sa, b, nb, kb);
1758 
		add_multi_char(c + sc, (unsigned long)0, CHAR_OCTAL);
1759 
	} else {
1760 
		/* Simple strings */
1761 
		sz = (gen_size)(nc + 1);
1762 
		c = xustr(sz);
1763 
		xumemcpy(c, a, (gen_size)na);
1764 
		xumemcpy(c + na, b, (gen_size)nb);
1765 
		c[nc] = 0;
1766 
	}
1767 
	MAKE_str_simple(nc, c, kc, res);
1768 
	prev = share_string_lit(res);
1769 
	if (!EQ_str(prev, res)) {
1770 
		/* Share string literals */
1771 
		unsigned long v;
1772 
		DESTROY_str_simple(destroy, res, nc, c, kc, v, res);
1773 
		xufree(c, sz);
1774 
		UNUSED(res);
1775 
		UNUSED(nc);
1776 
		UNUSED(kc);
1777 
		UNUSED(v);
1778 
		res = prev;
1779 
	}
1780 
	return(res);
2 7u83 1781 
}
1782 
 
1783 
 
1784 
/*
1785 
    FIND THE SHARED COPY OF A STRING LITERAL
1786 
 
1787 
    This routine is used to implement shared string literals.  It returns
1788 
    the canonical copy of s (i.e. the first string equal to s for which
1789 
    the routine was called).
1790 
*/
1791 
 
6 7u83 1792 
STRING
1793 
share_string_lit(STRING s)
2 7u83 1794 
{
6 7u83 1795 
	string a = DEREF_string(str_simple_text(s));
1796 
	unsigned long h = (hash(a)% HASH_STRING_SIZE);
1797 
	STRING p = string_hash_table[h];
1798 
	STRING t = p;
1799 
	while (!IS_NULL_str(t)) {
1800 
		if (eq_string_lit(t, s)) {
1801 
			return(t);
1802 
		}
1803 
		t = DEREF_str(str_next(t));
1804 
	}
1805 
	COPY_str(str_next(s), p);
1806 
	string_hash_table[h] = s;
1807 
	return(s);
2 7u83 1808 
}
1809 
 
1810 
 
1811 
/*
1812 
    GET THE NEXT CHARACTER FROM A STRING
1813 
 
1814 
    This routine returns the next character from the string s, using
1815 
    the tok field as a counter.  The character type is assigned to pc,
1816 
    including CHAR_NONE to indicate the end of the string.
1817 
*/
1818 
 
6 7u83 1819 
unsigned long
1820 
get_string_char(STRING s, int *pc)
2 7u83 1821 
{
6 7u83 1822 
	unsigned long c;
1823 
	unsigned long i = DEREF_ulong(str_simple_tok(s));
1824 
	unsigned long n = DEREF_ulong(str_simple_len(s));
1825 
	if (i < n) {
1826 
		string text = DEREF_string(str_simple_text(s));
1827 
		unsigned kind = DEREF_unsigned(str_simple_kind(s));
1828 
		if (kind & STRING_MULTI) {
1829 
			c = get_multi_char(text + MULTI_WIDTH * i, pc);
1830 
		} else {
1831 
			c = (unsigned long)text[i];
1832 
			*pc = CHAR_SIMPLE;
1833 
		}
2 7u83 1834 
	} else {
6 7u83 1835 
		c = 0;
1836 
		*pc = CHAR_NONE;
2 7u83 1837 
	}
6 7u83 1838 
	COPY_ulong(str_simple_tok(s), i + 1);
1839 
	return(c);
2 7u83 1840 
}
1841 
 
1842 
 
1843 
/*
1844 
    FIND A CHARACTER LITERAL
1845 
 
1846 
    This routine returns the character value corresponding to the character
1847 
    literal expression e.
1848 
*/
1849 
 
6 7u83 1850 
int
1851 
get_char_value(EXP e)
2 7u83 1852 
{
6 7u83 1853 
	int c = char_illegal;
1854 
	if (!IS_NULL_exp(e)) {
1855 
		if (IS_exp_int_lit(e)) {
1856 
			NAT n = DEREF_nat(exp_int_lit_nat(e));
1857 
			if (IS_nat_calc(n)) {
1858 
				e = DEREF_exp(nat_calc_value(n));
1859 
			}
2 7u83 1860 
		}
6 7u83 1861 
		if (IS_exp_cast(e)) {
1862 
			e = DEREF_exp(exp_cast_arg(e));
1863 
			if (IS_exp_int_lit(e)) {
1864 
				NAT n = DEREF_nat(exp_int_lit_nat(e));
1865 
				if (IS_nat_calc(n)) {
1866 
					e = DEREF_exp(nat_calc_value(n));
1867 
				}
1868 
			}
2 7u83 1869 
		}
6 7u83 1870 
		if (IS_exp_char_lit(e)) {
1871 
			STRING s = DEREF_str(exp_char_lit_str(e));
1872 
			unsigned kind = DEREF_unsigned(str_simple_kind(s));
1873 
			if (!(kind & STRING_MULTI)) {
1874 
				unsigned long len =
1875 
				    DEREF_ulong(str_simple_len(s));
1876 
				if (len == 1) {
1877 
					string t =
1878 
					    DEREF_string(str_simple_text(s));
1879 
					c = (int)*t;
1880 
				}
1881 
			}
1882 
		}
2 7u83 1883 
	}
6 7u83 1884 
	return(c);
2 7u83 1885 
}
1886 
 
1887 
 
1888 
/*
1889 
    EVALUATE A CHARACTER LITERAL
1890 
 
1891 
    This routine evaluates the character literal str by mapping it to
1892 
    its ASCII representation.  The value is stored in the tok field
1893 
    (the fact that LINK_NONE equals EXTENDED_MAX is convenient, but not
1894 
    essential).
1895 
*/
1896 
 
6 7u83 1897 
NAT
1898 
eval_char_lit(STRING str)
2 7u83 1899 
{
6 7u83 1900 
	NAT n;
1901 
	unsigned long v = DEREF_ulong(str_simple_tok(str));
1902 
	if (v == LINK_NONE) {
1903 
		unsigned long i;
1904 
		string s = DEREF_string(str_simple_text(str));
1905 
		unsigned long len = DEREF_ulong(str_simple_len(str));
1906 
		unsigned kind = DEREF_unsigned(str_simple_kind(str));
1907 
		if (kind & STRING_MULTI) {
1908 
			NAT b = make_small_nat(256);
1909 
			n = small_nat[0];
1910 
			for (i = 0; i < len; i++) {
1911 
				NAT d;
1912 
				int ch = CHAR_SIMPLE;
1913 
				unsigned long c = get_multi_char(s, &ch);
1914 
				if (ch == CHAR_SIMPLE) {
1915 
					c = to_ascii(c, &ch);
1916 
				}
1917 
				d = make_nat_value(c);
1918 
				n = binary_nat_op(exp_mult_tag, n, b);
1919 
				n = binary_nat_op(exp_plus_tag, n, d);
1920 
				s += MULTI_WIDTH;
1921 
			}
1922 
		} else {
1923 
			n = small_nat[0];
1924 
			for (i = 0; i < len; i++) {
1925 
				int ch = CHAR_SIMPLE;
1926 
				unsigned long c = (unsigned long)*s;
1927 
				c = to_ascii(c, &ch);
1928 
				n = make_nat_literal(n, (unsigned)256,
1929 
						     (unsigned)c);
1930 
				s++;
1931 
			}
1932 
		}
1933 
		v = get_nat_value(n);
1934 
		if (v != EXTENDED_MAX) {
1935 
			/* Store calculated value */
1936 
			COPY_ulong(str_simple_tok(str), v);
1937 
		}
2 7u83 1938 
	} else {
6 7u83 1939 
		/* Use stored value */
1940 
		n = make_nat_value(v);
2 7u83 1941 
	}
6 7u83 1942 
	return(n);
2 7u83 1943 
}
1944 
 
1945 
 
1946 
/*
1947 
    FIND A CHARACTER REPRESENTATION TYPE
1948 
 
1949 
    In the case where a character literal type doesn't fit into its type
1950 
    then this routine gives a type in which the literal value can be
1951 
    constructed and then converted into its underlying type.
1952 
*/
1953 
 
6 7u83 1954 
TYPE
1955 
find_char_type(NAT n)
2 7u83 1956 
{
6 7u83 1957 
	TYPE t;
1958 
	int fit = 0;
1959 
	string str = NULL_string;
1960 
	t = find_literal_type(n, BASE_OCTAL, SUFFIX_NONE, str, &fit);
1961 
	return(t);
2 7u83 1962 
}
1963 
 
1964 
 
1965 
/*
1966 
    CREATE A STRING OR CHARACTER LITERAL EXPRESSION
1967 
 
1968 
    This routine turns a string or character literal into an expression.
1969 
    Note that the type of a normal character literal varies between C
1970 
    (where it is a char cast to an int) and C++ (where it stays as a
1971 
    char), and also that a string, or wide string, literal is an lvalue
1972 
    of array type.
1973 
*/
1974 
 
6 7u83 1975 
EXP
1976 
make_string_exp(STRING s)
2 7u83 1977 
{
6 7u83 1978 
	EXP e;
1979 
	string text = DEREF_string(str_simple_text(s));
1980 
	unsigned long len = DEREF_ulong(str_simple_len(s));
1981 
	unsigned kind = DEREF_unsigned(str_simple_kind(s));
2 7u83 1982 
 
6 7u83 1983 
	if (kind & STRING_CHAR) {
1984 
		int fits = 0;
1985 
		int digit = -1;
1986 
		TYPE t0, t1, t2;
1987 
		NAT n = NULL_nat;
1988 
		ERROR err = NULL_err;
1989 
		if (kind & STRING_WIDE) {
1990 
			t0 = type_wchar_lit;
1991 
			t1 = t0;
1992 
			t2 = t0;
1993 
		} else if (len <= 1) {
1994 
			t0 = type_char;
1995 
			t1 = t0;
1996 
			t2 = type_char_lit;
1997 
		} else {
1998 
			report(crt_loc, ERR_lex_ccon_multi(s));
1999 
			t0 = type_mchar_lit;
2000 
			t1 = t0;
2001 
			t2 = t0;
2002 
		}
2003 
		if (len == 0) {
2004 
			fits = 1;
2005 
			n = small_nat[0];
2006 
			COPY_ulong(str_simple_tok(s), 0);
2007 
		} else if (len == 1) {
2008 
			if (kind & STRING_MULTI) {
2009 
				if (!(kind & STRING_FAT)) {
2010 
					/* Simple octal or hex escape
2011 
					 * sequence */
2012 
					unsigned long v =
2013 
					    DEREF_ulong(str_simple_tok(s));
2014 
					if (v == LINK_NONE) {
2015 
						int ch = CHAR_SIMPLE;
2016 
						v = get_multi_char(text, &ch);
2017 
						if (ch == CHAR_OCTAL ||
2018 
						    ch == CHAR_HEX) {
2019 
							if (v < 128)fits = 1;
2020 
							n = make_nat_value(v);
2021 
							COPY_ulong(str_simple_tok(s), v);
2022 
						}
2023 
					} else {
2024 
						if (v < 128)fits = 1;
2025 
						n = make_nat_value(v);
2026 
					}
2027 
				}
2028 
			} else {
2029 
				/* Single character */
2030 
				character c = text[0];
2031 
				if (in_hash_if_exp) {
2032 
					/* Evaluate character value
2033 
					 * immediately */
2034 
					unsigned long v =
2035 
					    DEREF_ulong(str_simple_tok(s));
2036 
					if (v == LINK_NONE) {
2037 
						int ch = CHAR_SIMPLE;
2038 
						v = (unsigned long)c;
2039 
						v = to_ascii(v, &ch);
2040 
						COPY_ulong(str_simple_tok(s),
2041 
							   v);
2042 
					}
2043 
					if (v < 128) {
2044 
						fits = 1;
2045 
					}
2046 
					n = make_nat_value(v);
2047 
				} else {
2048 
					if (c >= char_zero && c <= char_nine) {
2049 
						/* Allow for digits */
2050 
						digit = (int)(c - char_zero);
2051 
					}
2052 
				}
2 7u83 2053 
			}
2054 
		}
6 7u83 2055 
		if (IS_NULL_nat(n)) {
2056 
			/* Make character literal expression */
2057 
			MAKE_exp_char_lit(t0, s, digit, e);
2058 
			MAKE_nat_calc(e, n);
2 7u83 2059 
		} else {
6 7u83 2060 
			if (!fits && check_nat_range(t0, n)!= 0) {
2061 
				/* Value doesn't fit into t0 */
2062 
				t0 = find_char_type(n);
2063 
			}
2 7u83 2064 
		}
6 7u83 2065 
		MAKE_exp_int_lit(t0, n, exp_char_lit_tag, e);
2066 
		if (!EQ_type(t0, t1)) {
2067 
			/* Convert from t0 to t1 */
2068 
			e = make_cast_nat(t1, e, &err, CAST_STATIC);
2069 
		}
2070 
		if (!EQ_type(t1, t2)) {
2071 
			/* Convert from t1 to t2 */
2072 
			e = make_cast_nat(t2, e, &err, CAST_IMPLICIT);
2073 
		}
2074 
		if (!IS_NULL_err(err)) {
2075 
			report(crt_loc, err);
2076 
		}
2 7u83 2077 
	} else {
6 7u83 2078 
		/* String literals */
2079 
		TYPE t;
2080 
		NAT n = make_nat_value(len + 1);
2081 
		if (kind & STRING_WIDE) {
2082 
			t = type_wstring_lit;
2083 
		} else {
2084 
			t = type_string_lit;
2085 
		}
2086 
		MAKE_type_array(cv_lvalue, t, n, t);
2087 
		MAKE_exp_string_lit(t, s, e);
2 7u83 2088 
	}
6 7u83 2089 
	return(e);
2 7u83 2090 
}
2091 
 
2092 
 
2093 
/*
2094 
    CREATE A BOOLEAN LITERAL EXPRESSION
2095 
 
2096 
    This routine creates a boolean literal expression given by the boolean
2097 
    value b (which should be one of the values BOOL_FALSE and BOOL_TRUE
2098 
    defined in literal.h).
2099 
*/
2100 
 
6 7u83 2101 
EXP
2102 
make_bool_exp(unsigned b, unsigned tag)
2 7u83 2103 
{
6 7u83 2104 
	EXP e;
2105 
	NAT n = small_nat[b];
2106 
	MAKE_exp_int_lit(type_bool, n, tag, e);
2107 
	return(e);
2 7u83 2108 
}
2109 
 
2110 
 
2111 
/*
2112 
    TEST A BOOLEAN LITERAL EXPRESSION
2113 
 
2114 
    This routine is the reverse of the one above.  It returns the boolean
2115 
    value (BOOL_FALSE, BOOL_TRUE or BOOL_UNKNOWN) corresponding to the
2116 
    expression e.
2117 
*/
2118 
 
6 7u83 2119 
unsigned
2120 
test_bool_exp(EXP e)
2 7u83 2121 
{
6 7u83 2122 
	NAT n = DEREF_nat(exp_int_lit_nat(e));
2123 
	if (IS_nat_small(n)) {
2124 
		unsigned b = DEREF_unsigned(nat_small_value(n));
2125 
		if (b == BOOL_FALSE) {
2126 
			return(BOOL_FALSE);
2127 
		}
2128 
		if (b == BOOL_TRUE) {
2129 
			return(BOOL_TRUE);
2130 
		}
2131 
	}
2132 
	return(BOOL_UNKNOWN);
2 7u83 2133 
}