Subversion Repositories tendra.SVN

Rev

Rev 2 | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

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