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
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 "types.h"
63 
#include "read_types.h"
64 
#include "analyser.h"
65 
#include "check.h"
66 
#include "high.h"
67 
#include "names.h"
68 
#include "node.h"
69 
#include "read.h"
70 
#include "shape.h"
71 
#include "table.h"
72 
#include "tdf.h"
73 
#include "utility.h"
74 
 
75 
 
76 
/*
77 
    ARE MULTIBYTE STRINGS ALLOWED
78 
 
79 
    This flag is true to indicate that multibyte strings (other than
80 
    8 bits per character) are allowed.
81 
*/
82 
 
6 7u83 83 
boolean allow_multibyte = 1;
2 7u83 84 
 
85 
 
86 
/*
87 
    READ A TOKEN APPLICATION
88 
 
89 
    A token application of sort s is read and appended to p.
90 
*/
91 
 
6 7u83 92 
void
93 
read_token(node *p, sortname s)
2 7u83 94 
{
6 7u83 95 
    char *ra;
96 
    char *wtemp;
97 
    sortname rs;
98 
    construct *v;
99 
    tok_info *info;
100 
    boolean in_brackets = 0;
2 7u83 101 
 
102 
    /* Check bracket (1) */
6 7u83 103 
    read_word();
104 
    if (!func_input && word_type == INPUT_OPEN) {
105 
	in_brackets = 1;
106 
	read_word();
2 7u83 107 
    }
108 
 
109 
    /* Read token identifier */
6 7u83 110 
    if (word_type != INPUT_WORD) {
111 
	input_error("Token identifier expected");
112 
	return;
2 7u83 113 
    }
114 
 
115 
    /* Check bracket (2) */
6 7u83 116 
    if (func_input) {
117 
	wtemp = temp_copy(word);
118 
	read_word();
119 
	if (word_type == INPUT_OPEN) {
120 
	    in_brackets = 1;
2 7u83 121 
	} else {
6 7u83 122 
	    looked_ahead = 1;
2 7u83 123 
	}
124 
    } else {
6 7u83 125 
	wtemp = word;
2 7u83 126 
    }
127 
 
128 
    /* Look up token */
6 7u83 129 
    v = search_var_hash(wtemp, SORT_token);
130 
    if (v == null) {
131 
	input_error("Token %s not declared", wtemp);
132 
	return;
2 7u83 133 
    }
6 7u83 134 
    info = get_tok_info(v);
135 
    rs = info->res;
136 
    ra = info->args;
137 
    if (rs == SORT_unknown) {
138 
	input_error("Token %s not declared", wtemp);
139 
	return;
2 7u83 140 
    }
6 7u83 141 
    if (is_high(rs)) {
142 
	high_sort *h = high_sorts + high_no(rs);
143 
	rs = h->res;
144 
	ra = find_decode_string(h);
2 7u83 145 
    }
6 7u83 146 
    if (rs != s) {
147 
	input_error("Token %s returns %s, not %s", wtemp,
148 
		      sort_name(rs), sort_name(s));
149 
	return;
2 7u83 150 
    }
6 7u83 151 
    adjust_token(v);
2 7u83 152 
 
153 
    /* Decode arguments */
6 7u83 154 
    p->son = new_node();
155 
    p->son->cons = v;
156 
    if (ra)p->son->son = read_node(ra);
2 7u83 157 
 
158 
    /* Check end */
6 7u83 159 
    if (in_brackets) {
160 
	read_word();
161 
	if (word_type != INPUT_CLOSE) {
162 
	    is_fatal = 0;
163 
	    input_error("End of token %s construct expected", v->name);
164 
	    looked_ahead = 1;
2 7u83 165 
	}
166 
    } else {
6 7u83 167 
	if (p->son->son) {
168 
	    is_fatal = 0;
169 
	    input_error("Token %s construct should be in brackets",
170 
			  v->name);
2 7u83 171 
	}
172 
    }
6 7u83 173 
    if (do_check)IGNORE set_token_args(info->pars, p->son->son, 0);
174 
    return;
2 7u83 175 
}
176 
 
177 
 
178 
/*
179 
    READ A TOKEN NAME
180 
 
181 
    This routine reads a token name (as opposed to a token application).
182 
    The token should have sort s.
183 
*/
184 
 
6 7u83 185 
static node *
186 
read_token_name(sortname s)
2 7u83 187 
{
6 7u83 188 
    node *p;
189 
    boolean ok = 0;
190 
    construct *v;
191 
    high_sort *h;
192 
    tok_info *info;
2 7u83 193 
 
194 
    /* Read token identifier */
6 7u83 195 
    read_word();
196 
    if (word_type != INPUT_WORD) {
197 
	input_error("Token identifier expected");
198 
	return(null);
2 7u83 199 
    }
200 
 
201 
    /* Look up token */
6 7u83 202 
    v = search_var_hash(word, SORT_token);
203 
    if (v == null) {
204 
	input_error("Token %s not declared", word);
205 
	return(null);
2 7u83 206 
    }
6 7u83 207 
    info = get_tok_info(v);
2 7u83 208 
 
209 
    /* Check consistency */
6 7u83 210 
    h = high_sorts + high_no(s);
211 
    if (h->res == info->res) {
212 
	if (info->args == null) {
213 
	    if (h->no_args == 0)ok = 1;
214 
	} else if (h->no_args) {
215 
	    char *ha = find_decode_string(h);
216 
	    if (streq(info->args, ha))ok = 1;
2 7u83 217 
	}
6 7u83 218 
    } else if (h->id == info->res) {
219 
	if (info->args == null)ok = 1;
2 7u83 220 
    }
6 7u83 221 
    if (!ok) {
222 
	input_error("Token %s has incorrect sort", v->name);
2 7u83 223 
    }
224 
 
225 
    /* Return the construct */
6 7u83 226 
    p = new_node();
227 
    p->cons = v;
228 
    if (!text_output) {
229 
	p->son = new_node();
230 
	p->son->cons = &token_cons;
2 7u83 231 
    }
6 7u83 232 
    return(p);
2 7u83 233 
}
234 
 
235 
 
236 
/*
237 
    FIND BASIC CONSTRUCT FOR A VARIABLE SORT
238 
 
239 
    This routine returns the construct for turning an identifier into
240 
    an object of sort s.
241 
*/
242 
 
6 7u83 243 
static long
244 
make_obj(sortname s)
2 7u83 245 
{
6 7u83 246 
    long mk = -1;
247 
    switch (s) {
248 
	case SORT_al_tag: mk = ENC_make_al_tag; break;
249 
	case SORT_label: mk = ENC_make_label; break;
250 
	case SORT_tag: mk = ENC_make_tag; break;
2 7u83 251 
    }
6 7u83 252 
    return(mk);
2 7u83 253 
}
254 
 
255 
 
256 
/*
257 
    IS A VARIABLE SORT A USE OR AN INTRODUCTION?
258 
 
259 
    This flag is true to indicate that the tag (or whatever) being read
260 
    is a new one being introduced rather than an old one being used.
261 
    The flag intro_tag_var is set to indicate that any tag so introduced
262 
    is a variable.  The flag intro_visible is set to true whenever the
263 
    visible access specifier is read.
264 
*/
265 
 
6 7u83 266 
static boolean intro_var = 0;
267 
static boolean intro_tag_var = 0;
268 
boolean intro_visible = 0;
2 7u83 269 
 
270 
 
271 
/*
272 
    SEARCH FOR A VARIABLE SORT
273 
 
274 
    This routine initializes, if appropriate, and returns the construct
275 
    corresponding to the object named nm of sort s.
276 
*/
277 
 
6 7u83 278 
static construct *
279 
search_var_sort(char *nm, sortname s)
2 7u83 280 
{
6 7u83 281 
    construct *v = search_var_hash(nm, s);
282 
    if (intro_var) {
283 
	if (v == null) {
284 
	    v = make_construct(s);
285 
	    v->name = string_copy_aux(nm);
2 7u83 286 
	    /* Don't add to hash table yet */
6 7u83 287 
	    if (s == SORT_tag) {
288 
		tag_info *info = get_tag_info(v);
289 
		info->var = intro_tag_var;
290 
		info->vis = intro_visible;
291 
		intro_visible = 0;
2 7u83 292 
	    }
293 
	} else {
6 7u83 294 
	    input_error("%s %s already in scope", sort_name(s), nm);
2 7u83 295 
	}
296 
    } else {
6 7u83 297 
	if (v == null) {
298 
	    if (!dont_check) {
299 
		is_fatal = 0;
300 
		input_error("%s %s not in scope", sort_name(s), nm);
2 7u83 301 
	    }
6 7u83 302 
	    v = make_construct(s);
303 
	    v->name = string_copy_aux(nm);
304 
	    IGNORE add_to_var_hash(v, s);
2 7u83 305 
	}
306 
    }
6 7u83 307 
    return(v);
2 7u83 308 
}
309 
 
310 
 
311 
/*
312 
    READ A VARIABLE SORT
313 
 
314 
    An identifier representing a construct of sort s is read.
315 
*/
316 
 
6 7u83 317 
node *
318 
read_var_sort(sortname s)
2 7u83 319 
{
6 7u83 320 
    node *p;
321 
    construct *v;
322 
    read_word();
323 
    if (word_type != INPUT_WORD) {
324 
	input_error("%s identifier expected", sort_name(s));
2 7u83 325 
    }
6 7u83 326 
    v = search_var_sort(word, s);
327 
    p = new_node();
328 
    p->cons = v;
329 
    return(p);
2 7u83 330 
}
331 
 
332 
 
333 
/*
334 
    READ A SEQUENCE EXPRESSION
335 
 
336 
    A sequence expression is read.  This is tricky because it is a list
337 
    of exps followed by an exp, which may be read as a list of exps.
338 
*/
339 
 
6 7u83 340 
void
341 
read_seq_node(node *p)
2 7u83 342 
{
6 7u83 343 
    node *q = read_node("*[x]?[x]");
344 
    if (q->bro->son) {
345 
	node *r = q->bro->son;
346 
	q->bro = r;
347 
	p->son = q;
348 
	return;
2 7u83 349 
    }
6 7u83 350 
    q->bro = null;
351 
    if (q->cons->encoding == 0) {
352 
	is_fatal = 0;
353 
	input_error("exp expected");
354 
	return;
2 7u83 355 
    }
6 7u83 356 
   (q->cons->encoding) --;
357 
    p->son = q;
358 
    q = q->son;
359 
    if (q->bro == null) {
360 
	p->son->son = null;
361 
	p->son->bro = q;
2 7u83 362 
    } else {
6 7u83 363 
	while (q->bro->bro)q = q->bro;
364 
	p->son->bro = q->bro;
365 
	q->bro = null;
2 7u83 366 
    }
6 7u83 367 
    return;
2 7u83 368 
}
369 
 
370 
 
371 
/*
372 
    READ SORT INDICATED BY A SINGLE DECODE LETTER
373 
 
374 
    An object with sort given by the decode letter str is read.  If the next
375 
    object is not of this sort then either an error is flagged (if strict
376 
    is true) or null is returned.
377 
*/
378 
 
6 7u83 379 
static node *
380 
read_node_aux(char *str, int strict)
2 7u83 381 
{
6 7u83 382 
    sortname s;
383 
    char *wtemp;
384 
    node *p, *ps;
385 
    construct *cons;
386 
    read_func fn = null;
387 
    boolean in_brackets = 0;
2 7u83 388 
 
389 
    /* Find the corresponding sort name */
6 7u83 390 
    if (str[1] == '&') {
2 7u83 391 
	/* Introduced variable */
6 7u83 392 
	intro_var = 1;
393 
	intro_tag_var = 1;
394 
    } else if (str[1] == '^') {
2 7u83 395 
	/* Introduced identity */
6 7u83 396 
	intro_var = 1;
397 
	intro_tag_var = 0;
2 7u83 398 
    }
6 7u83 399 
    switch (str[0]) {
400 
	case 'i': {
401 
	    s = SORT_tdfint;
402 
	    break;
2 7u83 403 
	}
6 7u83 404 
	case 'j': {
405 
	    s = SORT_tdfbool;
406 
	    break;
2 7u83 407 
	}
6 7u83 408 
	case '$': {
409 
	    s = SORT_tdfstring;
410 
	    break;
2 7u83 411 
	}
6 7u83 412 
	case 'F': {
413 
	    s = SORT_unknown;
414 
	    break;
2 7u83 415 
	}
416 
	default : {
6 7u83 417 
	    s = find_sort(str[0]);
418 
	    fn = sort_read[s];
419 
	    break;
2 7u83 420 
	}
421 
    }
422 
 
423 
    /* Read the next word */
6 7u83 424 
    read_word();
2 7u83 425 
 
426 
    /* Check for blanks */
6 7u83 427 
    if (word_type == INPUT_BLANK && !strict) {
428 
	word_type = INPUT_BLANK_FIRST;
429 
	return(null);
2 7u83 430 
    }
431 
 
432 
    /* Check for bars */
6 7u83 433 
    if (word_type == INPUT_BAR && !strict) {
434 
	word_type = INPUT_BAR_FIRST;
435 
	return(null);
2 7u83 436 
    }
437 
 
438 
    /* Deal with strings */
6 7u83 439 
    if (s == SORT_tdfstring) {
440 
	if (word_type == INPUT_STRING) {
441 
	    p = new_node();
442 
	    p->cons = new_construct();
443 
	    p->cons->sortnum = SORT_tdfstring;
444 
	    p->cons->encoding = word_length;
445 
	    p->cons->name = string_copy(word,(int)word_length);
446 
	    p->cons->next = null;
447 
	    return(p);
2 7u83 448 
	} else {
6 7u83 449 
	    boolean is_multibyte = 0;
450 
	    if (func_input) {
451 
		if (word_type == INPUT_WORD) {
452 
		    if (streq(word, MAKE_STRING)) {
453 
			read_word();
454 
			if (word_type == INPUT_OPEN)is_multibyte = 1;
2 7u83 455 
		    }
456 
		}
457 
	    } else {
6 7u83 458 
		if (word_type == INPUT_OPEN) {
459 
		    read_word();
460 
		    if (word_type == INPUT_WORD) {
461 
			if (streq(word, MAKE_STRING))is_multibyte = 1;
2 7u83 462 
		    }
463 
		}
464 
	    }
6 7u83 465 
	    if (is_multibyte) {
466 
		if (!allow_multibyte) {
467 
		    input_error("Multibyte strings not allowed here");
2 7u83 468 
		}
6 7u83 469 
		p = new_node();
470 
		p->cons = &string_cons;
471 
		p->son = read_node("i*[i]");
472 
		read_word();
473 
		if (word_type != INPUT_CLOSE) {
474 
		    input_error("End of multibyte string expected");
2 7u83 475 
		}
6 7u83 476 
		return(p);
2 7u83 477 
	    }
478 
	}
6 7u83 479 
	if (strict)input_error("String expected");
480 
	return(null);
2 7u83 481 
    }
482 
 
483 
    /* Deal with numbers */
6 7u83 484 
    if (word_type == INPUT_NUMBER) {
485 
	boolean negate = 0;
486 
	if (*word == '-') {
487 
	    word++;
488 
	    negate = 1;
2 7u83 489 
	}
6 7u83 490 
	p = new_node();
491 
	p->cons = new_construct();
492 
	if (fits_ulong(word, 1)) {
493 
	    p->cons->sortnum = SORT_small_tdfint;
494 
	    p->cons->encoding = (long)octal_to_ulong(word);
2 7u83 495 
	} else {
6 7u83 496 
	    p->cons->sortnum = SORT_tdfint;
497 
	    p->cons->name = string_copy_aux(word);
2 7u83 498 
	}
499 
 
6 7u83 500 
	switch (s) {
501 
	    case SORT_tdfint: {
502 
		if (negate) {
503 
		    is_fatal = 0;
504 
		    input_error("Negative nat");
2 7u83 505 
		}
6 7u83 506 
		return(p);
2 7u83 507 
	    }
6 7u83 508 
	    case SORT_tdfbool: {
509 
		node *q = new_node();
510 
		q->cons = (negate ? &true_cons : &false_cons);
511 
		q->bro = p;
512 
		return(q);
2 7u83 513 
	    }
6 7u83 514 
	    case SORT_nat: {
515 
		node *q = new_node();
516 
		if (negate) {
517 
		    is_fatal = 0;
518 
		    input_error("Negative nat");
2 7u83 519 
		}
6 7u83 520 
		q->cons = cons_no(SORT_nat, ENC_make_nat);
521 
		q->son = p;
522 
		return(q);
2 7u83 523 
	    }
6 7u83 524 
	    case SORT_signed_nat: {
525 
		node *q = new_node();
526 
		q->cons = cons_no(SORT_signed_nat, ENC_make_signed_nat);
527 
		q->son = new_node();
528 
		q->son->cons = (negate ? &true_cons : &false_cons);
529 
		q->son->bro = p;
530 
		return(q);
2 7u83 531 
	    }
532 
	    default : {
6 7u83 533 
		if (strict)input_error("%s expected", sort_name(s));
534 
		return(null);
2 7u83 535 
	    }
536 
	}
537 
    }
538 
 
539 
    /* Deal with strings */
6 7u83 540 
    if (word_type == INPUT_STRING) {
541 
	if (s == SORT_string) {
542 
	    node *q;
543 
	    p = new_node();
544 
	    p->cons = new_construct();
545 
	    p->cons->sortnum = SORT_tdfstring;
546 
	    p->cons->encoding = word_length;
547 
	    p->cons->name = string_copy(word,(int)word_length);
548 
	    p->cons->next = null;
549 
	    q = new_node();
550 
	    q->cons = cons_no(SORT_string, ENC_make_string);
551 
	    q->son = p;
552 
	    return(q);
2 7u83 553 
	}
554 
    }
555 
 
556 
    /* That was the last chance for numbers */
6 7u83 557 
    if (fn == null) {
558 
	if (strict)input_error("Number expected");
559 
	return(null);
2 7u83 560 
    }
561 
 
562 
    /* Check for brackets (1) */
6 7u83 563 
    if (!func_input && word_type == INPUT_OPEN) {
564 
	in_brackets = 1;
565 
	read_word();
2 7u83 566 
    }
567 
 
568 
    /* The next word should be the identifier */
6 7u83 569 
    if (word_type != INPUT_WORD) {
570 
	if (strict)input_error("%s expected", sort_name(s));
571 
	return(null);
2 7u83 572 
    }
573 
 
574 
    /* Check for brackets (2) */
6 7u83 575 
    if (func_input) {
576 
	wtemp = temp_copy(word);
577 
	read_word();
578 
	if (word_type == INPUT_OPEN) {
579 
	    in_brackets = 1;
2 7u83 580 
	} else {
6 7u83 581 
	    looked_ahead = 1;
2 7u83 582 
	}
583 
    } else {
6 7u83 584 
	wtemp = word;
2 7u83 585 
    }
586 
 
6 7u83 587 
    if (s == SORT_string && streq(word, MAKE_STRING)) {
588 
	node *q;
589 
	p = new_node();
590 
	p->cons = &string_cons;
591 
	p->son = read_node("i*[i]");
592 
	read_word();
593 
	if (word_type != INPUT_CLOSE) {
594 
	    input_error("End of multibyte string expected");
2 7u83 595 
	}
6 7u83 596 
	q = new_node();
597 
	q->cons = cons_no(SORT_string, ENC_make_string);
598 
	q->son = p;
599 
	return(q);
2 7u83 600 
    }
601 
 
602 
    /* Look up construct */
6 7u83 603 
    cons = search_cons_hash(wtemp, s);
604 
    if (cons) {
605 
	p = fn(cons->encoding);
606 
	ps = p->son;
2 7u83 607 
    } else {
6 7u83 608 
	boolean do_check_tag = 0;
609 
	if (!in_brackets && (s == SORT_al_tag || s == SORT_label ||
610 
			       s == SORT_tag)) {
611 
	    do_check_tag = 1;
2 7u83 612 
	}
613 
	/* Look up token */
6 7u83 614 
	cons = search_var_hash(wtemp, SORT_token);
615 
	if (cons) {
616 
	    tok_info *info = get_tok_info(cons);
617 
	    sortname rs = info->res;
618 
	    char *ra = info->args;
619 
	    if (rs == SORT_unknown) {
620 
		if (do_check_tag)goto check_lab;
621 
		input_error("Token %s not declared", wtemp);
2 7u83 622 
	    }
6 7u83 623 
	    if (is_high(rs)) {
624 
		high_sort *h = high_sorts + high_no(rs);
625 
		rs = h->res;
626 
		ra = find_decode_string(h);
2 7u83 627 
	    }
6 7u83 628 
	    if (rs != s) {
629 
		if (do_check_tag)goto check_lab;
630 
		if (!strict) return(null);
631 
		input_error("Token %s returns %s, not %s", wtemp,
632 
			      sort_name(rs), sort_name(s));
2 7u83 633 
	    }
6 7u83 634 
	    adjust_token(cons);
635 
	    p = new_node();
636 
	    p->cons = cons_no(s, sort_tokens[s]);
637 
	    p->son = new_node();
638 
	    p->son->cons = cons;
639 
	    if (ra)p->son->son = read_node(ra);
640 
	    ps = p->son->son;
641 
	    if (do_check) {
642 
		IGNORE set_token_args(info->pars, p->son->son, 0);
643 
		if (s == SORT_exp)check_exp(p);
2 7u83 644 
	    }
645 
	} else {
646 
	    /* Look up label, tag etc */
6 7u83 647 
	    if (do_check_tag) {
648 
		check_lab : cons = search_var_sort(wtemp, s);
2 7u83 649 
	    }
6 7u83 650 
	    if (cons) {
651 
		long mk = make_obj(s);
652 
		p = new_node();
653 
		p->cons = cons_no(s, mk);
654 
		p->son = new_node();
655 
		p->son->cons = cons;
656 
		ps = null;
2 7u83 657 
	    } else {
6 7u83 658 
		if (strict) {
659 
		    input_error("Illegal %s, %s", sort_name(s), wtemp);
2 7u83 660 
		}
6 7u83 661 
		return(null);
2 7u83 662 
	    }
663 
	}
664 
    }
665 
 
666 
    /* Check end of construct */
6 7u83 667 
    if (in_brackets) {
668 
	read_word();
669 
	if (word_type != INPUT_CLOSE) {
670 
	    is_fatal = 0;
671 
	    input_error("End of %s construct expected", cons->name);
672 
	    looked_ahead = 1;
2 7u83 673 
	}
674 
    } else {
6 7u83 675 
	if (ps) {
676 
	    is_fatal = 0;
677 
	    input_error("%s construct should be in brackets", cons->name);
2 7u83 678 
	}
679 
    }
6 7u83 680 
    return(p);
2 7u83 681 
}
682 
 
683 
 
684 
/*
685 
    BRING VARIABLES INTO AND OUT OF SCOPE
686 
 
687 
    The tags, labels etc introduced in p are brought into (if end is
688 
    false) or out of (if end is true) scope.  This only works because
689 
    all the constructs which introduce these variables are of a fairly
690 
    simple form.
691 
*/
692 
 
6 7u83 693 
static void
694 
adjust_scope(node *p, int end)
2 7u83 695 
{
6 7u83 696 
    node *p0 = p;
697 
    while (p) {
698 
	construct *v = p->cons;
699 
	sortname s = v->sortnum;
700 
	switch (s) {
2 7u83 701 
 
6 7u83 702 
	    case SORT_repeat:
703 
	    case SORT_option: {
2 7u83 704 
		/* Scan repeated and optional arguments */
6 7u83 705 
		if (p->son)adjust_scope(p->son, end);
706 
		break;
2 7u83 707 
	    }
708 
 
6 7u83 709 
	    case SORT_al_tag:
710 
	    case SORT_label:
711 
	    case SORT_tag: {
2 7u83 712 
		/* Variable found - adjust scope */
6 7u83 713 
		if (v->encoding == make_obj(s)) {
714 
		    construct *u = p->son->cons;
715 
		    if (end) {
716 
			if (s == SORT_tag) {
2 7u83 717 
			    /* Visible tags aren't removed */
6 7u83 718 
			    tag_info *info = get_tag_info(u);
719 
			    if (info->vis)break;
2 7u83 720 
			}
6 7u83 721 
			remove_var_hash(u->name, s);
2 7u83 722 
		    } else {
6 7u83 723 
			if (add_to_var_hash(u, s)) {
724 
			    input_error("%s %s already in scope",
725 
					  sort_name(s), u->name);
2 7u83 726 
			}
6 7u83 727 
			if (do_check && s == SORT_tag) {
2 7u83 728 
			    /* Fill in shape of tag */
6 7u83 729 
			    node *ts;
730 
			    node *p1 = p->bro;
731 
			    tag_info *info = get_tag_info(u);
732 
			    if (p1 && p1->cons->sortnum == SORT_exp) {
2 7u83 733 
				/* identity and variable have "t&x" */
6 7u83 734 
				ts = p1->shape;
735 
			    } else if (p0->cons->sortnum == SORT_shape) {
2 7u83 736 
				/* make_proc etc have "S?[u]t&" */
6 7u83 737 
				ts = copy_node(p0);
2 7u83 738 
			    } else {
739 
				/* don't know about other constructs */
6 7u83 740 
				ts = null;
2 7u83 741 
			    }
742 
			    /* Declaration = ?[u]?[X]S from 4.0 */
6 7u83 743 
			    info->dec = new_node();
744 
			    info->dec->cons = &false_cons;
745 
			    info->dec->bro = new_node();
746 
			    info->dec->bro->cons = &false_cons;
747 
			    info->dec->bro->bro = ts;
2 7u83 748 
			}
749 
		    }
750 
		}
6 7u83 751 
		break;
2 7u83 752 
	    }
753 
	}
6 7u83 754 
	p = p->bro;
2 7u83 755 
    }
6 7u83 756 
    return;
2 7u83 757 
}
758 
 
759 
 
760 
/*
761 
    CHECK FOR COMMA OR CLOSE BRACKET
762 
 
763 
    The next word should be a comma, which is stepped over, or a close
764 
    bracket.
765 
*/
766 
 
6 7u83 767 
static void
768 
check_comma(void)
2 7u83 769 
{
6 7u83 770 
    read_word();
771 
    if (word_type == INPUT_COMMA) {
772 
	read_word();
773 
	looked_ahead = 1;
774 
	if (word_type == INPUT_CLOSE) {
775 
	    is_fatal = 0;
776 
	    input_error("Badly placed comma");
2 7u83 777 
	}
6 7u83 778 
	return;
2 7u83 779 
    }
6 7u83 780 
    if (word_type != INPUT_CLOSE) {
781 
	is_fatal = 0;
782 
	input_error("Comma or close bracket expected");
2 7u83 783 
    }
6 7u83 784 
    looked_ahead = 1;
785 
    return;
2 7u83 786 
}
787 
 
788 
 
789 
/*
790 
    READ SORTS GIVEN BY A STRING OF DECODE LETTERS
791 
 
792 
    A node corresponding to the decode string str is read from the
793 
    input file.
794 
*/
795 
 
6 7u83 796 
node *
797 
read_node(char *str)
2 7u83 798 
{
6 7u83 799 
    char c;
800 
    position store;
801 
    node *p, *q = null, *qe = null;
802 
    while (c = *str,(c != 0 && c != ']')) {
803 
	switch (c) {
2 7u83 804 
 
6 7u83 805 
	    case '{': {
2 7u83 806 
		/* Start of scope */
6 7u83 807 
		adjust_scope(q, 0);
808 
		p = null;
809 
		break;
2 7u83 810 
	    }
811 
 
6 7u83 812 
	    case '}': {
2 7u83 813 
		/* End of scope */
6 7u83 814 
		adjust_scope(q, 1);
815 
		p = null;
816 
		break;
2 7u83 817 
	    }
818 
 
6 7u83 819 
	    case '[':
820 
	    case '|':
821 
	    case '&':
822 
	    case '^': {
2 7u83 823 
		/* Ignore these cases */
6 7u83 824 
		p = null;
825 
		break;
2 7u83 826 
	    }
827 
 
6 7u83 828 
	    case '*':
829 
	    case '!': {
2 7u83 830 
		/* Repeats */
6 7u83 831 
		char cr;
832 
		char *sr;
833 
		long n = 0;
834 
		int opt = 0;
835 
		node *pe = null, *pr;
836 
		str += 2;
837 
		cr = *str;
838 
		sr = str;
839 
		if (cr == '?') {
2 7u83 840 
		    /* Allow for lists of options */
6 7u83 841 
		    opt = 1;
842 
		    str += 2;
843 
		    cr = *str;
844 
		    sr = skip_text(str);
2 7u83 845 
		}
6 7u83 846 
		if (cr == '*' || cr == '!') {
847 
		    input_error("Sorry, lists of lists not implemented");
848 
		} else if (cr == '?') {
849 
		    input_error("Sorry, lists of options not implemented");
2 7u83 850 
		}
6 7u83 851 
		p = new_node();
852 
		p->cons = new_construct();
853 
		p->cons->sortnum = SORT_repeat;
2 7u83 854 
		do {
6 7u83 855 
		    store_position(&store);
856 
		    pr = read_node_aux(sr, 0);
857 
		    if (pr || (opt && word_type == INPUT_BLANK_FIRST)) {
858 
			if (func_input)check_comma();
859 
			if (opt) {
2 7u83 860 
			    /* Allow for optionals */
6 7u83 861 
			    node *pt = pr;
862 
			    if (pt && str[1]!= ']') {
863 
				pt->bro = read_node(str + 1);
2 7u83 864 
			    }
6 7u83 865 
			    pr = new_node();
866 
			    pr->cons = &optional_cons;
867 
			    pr->son = pt;
2 7u83 868 
			}
6 7u83 869 
			if (sr[1]!= ']') {
870 
			    pr->bro = read_node(sr + 1);
2 7u83 871 
			}
6 7u83 872 
			if (pe == null) {
873 
			    p->son = pr;
2 7u83 874 
			} else {
6 7u83 875 
			    pe->bro = pr;
2 7u83 876 
			}
6 7u83 877 
			pe = pr;
878 
			while (pe->bro)pe = pe->bro;
879 
			n++;
2 7u83 880 
		    } else {
6 7u83 881 
			if (word_type == INPUT_BAR_FIRST) {
882 
			    if (func_input)check_comma();
883 
			} else if (c == '!' && n == 0 &&
884 
				    word_type == INPUT_BLANK_FIRST) {
885 
			    if (func_input)check_comma();
2 7u83 886 
			} else {
6 7u83 887 
			    set_position(&store);
2 7u83 888 
			}
889 
		    }
6 7u83 890 
		} while (pr);
891 
		p->cons->encoding = n;
892 
		if (opt)sr++;
893 
		str = skip_text(sr);
894 
		if (c == '!') {
2 7u83 895 
		    /* Optional repeats */
6 7u83 896 
		    node *pt = p;
897 
		    p = new_node();
898 
		    p->cons = &optional_cons;
899 
		    if (n)p->son = pt;
2 7u83 900 
		}
6 7u83 901 
		break;
2 7u83 902 
	    }
903 
 
6 7u83 904 
	    case '?': {
2 7u83 905 
		/* Optionals */
6 7u83 906 
		node *po;
907 
		char co;
908 
		str += 2;
909 
		co = *str;
910 
		if (co == '*' || co == '!') {
911 
		    input_error("Sorry, optional lists not implemented");
912 
		} else if (co == '?') {
913 
		    input_error("Sorry, optional options not implemented");
2 7u83 914 
		}
6 7u83 915 
		intro_visible = 0;
916 
		store_position(&store);
917 
		po = read_node_aux(str, 0);
918 
		if (po) {
919 
		    if (func_input)check_comma();
920 
		    if (str[1]!= ']') {
921 
			po->bro = read_node(str + 1);
2 7u83 922 
		    }
923 
		} else {
6 7u83 924 
		    if (word_type == INPUT_BLANK_FIRST) {
925 
			if (func_input)check_comma();
2 7u83 926 
		    } else {
6 7u83 927 
			set_position(&store);
2 7u83 928 
		    }
929 
		}
6 7u83 930 
		p = new_node();
931 
		p->cons = &optional_cons;
932 
		p->son = po;
933 
		str = skip_text(str);
934 
		break;
2 7u83 935 
	    }
936 
 
6 7u83 937 
	    case '@': {
2 7u83 938 
		/* Conditionals */
6 7u83 939 
		str += 2;
940 
		p = new_node();
941 
		p->cons = &bytestream_cons;
942 
		p->son = read_node(str);
943 
		str = skip_text(str);
944 
		break;
2 7u83 945 
	    }
946 
 
6 7u83 947 
	    case 'T': {
2 7u83 948 
		/* Tokens */
6 7u83 949 
		sortname sn;
950 
		str = find_sortname(str, &sn);
951 
		p = read_token_name(sn);
952 
		break;
2 7u83 953 
	    }
954 
 
955 
	    default : {
956 
		/* Simple sort */
6 7u83 957 
		p = read_node_aux(str, 1);
958 
		if (func_input)check_comma();
959 
		break;
2 7u83 960 
	    }
961 
	}
6 7u83 962 
	if (p) {
963 
	    if (qe == null) {
964 
		q = p;
2 7u83 965 
	    } else {
6 7u83 966 
		qe->bro = p;
2 7u83 967 
	    }
6 7u83 968 
	    qe = p;
969 
	    while (qe->bro)qe = qe->bro;
970 
	    intro_var = 0;
2 7u83 971 
	}
6 7u83 972 
	str++;
2 7u83 973 
    }
6 7u83 974 
    return(q);
2 7u83 975 
}