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
*/
29
 
59
 
30
 
60
 
31
#include "config.h"
61
#include "config.h"
32
#include "types.h"
62
#include "types.h"
33
#include "alignment.h"
63
#include "alignment.h"
-
 
64
#include "check.h"
34
#include "eval.h"
65
#include "eval.h"
35
#include "node.h"
66
#include "node.h"
36
#include "read.h"
67
#include "read.h"
37
#include "shape.h"
68
#include "shape.h"
38
#include "table.h"
69
#include "table.h"
Line 44... Line 75...
44
    SHAPE CHECKING FLAG
75
    SHAPE CHECKING FLAG
45
 
76
 
46
    This flag is true to indicate that shape checking should be applied.
77
    This flag is true to indicate that shape checking should be applied.
47
*/
78
*/
48
 
79
 
49
boolean do_check = 0 ;
80
boolean do_check = 0;
50
 
81
 
51
 
82
 
52
/*
83
/*
53
    THE NAME OF THE CURRENT EXPRESSION BEING CHECKED
84
    THE NAME OF THE CURRENT EXPRESSION BEING CHECKED
54
 
85
 
55
    The shape checking does not always take place immediately.  By
86
    The shape checking does not always take place immediately.  By
56
    printing the name of the expression being checked it is easier
87
    printing the name of the expression being checked it is easier
57
    to find any errors.
88
    to find any errors.
58
*/
89
*/
59
 
90
 
60
char *checking = "????" ;
91
char *checking = "????";
61
 
92
 
62
 
93
 
63
/*
94
/*
64
    SHAPE CHECKING FOR EXP_APPLY_TOKEN
95
    SHAPE CHECKING FOR EXP_APPLY_TOKEN
65
 
96
 
66
    The shape checking for the exp_apply_token construct p is implemented
97
    The shape checking for the exp_apply_token construct p is implemented
67
    by this routine.
98
    by this routine.
68
*/
99
*/
69
 
100
 
70
static void chk_token
101
static void
71
    PROTO_N ( ( p ) )
-
 
72
    PROTO_T ( node *p )
102
chk_token(node *p)
73
{
103
{
74
    tok_info *info = get_tok_info ( p->son->cons ) ;
104
    tok_info *info = get_tok_info(p->son->cons);
75
    node *d = info->def ;
105
    node *d = info->def;
76
    if ( d ) {
106
    if (d) {
77
	if ( d->cons->sortnum == SORT_completion ) d = d->son ;
107
	if (d->cons->sortnum == SORT_completion)d = d->son;
78
	p->shape = normalize ( d->shape ) ;
108
	p->shape = normalize(d->shape);
79
    } else {
109
    } else {
80
	p->shape = new_node () ;
110
	p->shape = new_node();
81
	p->shape->cons = &shape_of ;
111
	p->shape->cons = &shape_of;
82
	p->shape->son = copy_node ( p->son ) ;
112
	p->shape->son = copy_node(p->son);
83
    }
113
    }
84
    return ;
114
    return;
85
}
115
}
86
 
116
 
87
 
117
 
88
/*
118
/*
89
    SHAPE CHECKING FOR EXP_COND
119
    SHAPE CHECKING FOR EXP_COND
Line 92... Line 122...
92
    this routine.  Checking that the control argument is an integer is
122
    this routine.  Checking that the control argument is an integer is
93
    carried out for all _cond constructs as part of the main reading
123
    carried out for all _cond constructs as part of the main reading
94
    and decoding routines for the decode letter '@'.
124
    and decoding routines for the decode letter '@'.
95
*/
125
*/
96
 
126
 
97
static void chk_cond
127
static void
98
    PROTO_N ( ( p ) )
-
 
99
    PROTO_T ( node *p )
128
chk_cond(node *p)
100
{
129
{
101
    node *s ;
130
    node *s;
102
    node *q1 = p->son->bro->son ;
131
    node *q1 = p->son->bro->son;
103
    node *q2 = p->son->bro->bro->son ;
132
    node *q2 = p->son->bro->bro->son;
104
    node *s1 = q1->shape ;
133
    node *s1 = q1->shape;
105
    node *s2 = q2->shape ;
134
    node *s2 = q2->shape;
106
    if ( q1->cons->encoding == ENC_fail_installer ) {
135
    if (q1->cons->encoding == ENC_fail_installer) {
107
	p->shape = normalize ( s2 ) ;
136
	p->shape = normalize(s2);
108
	return ;
137
	return;
109
    }
138
    }
110
    if ( q2->cons->encoding == ENC_fail_installer ) {
139
    if (q2->cons->encoding == ENC_fail_installer) {
111
	p->shape = normalize ( s1 ) ;
140
	p->shape = normalize(s1);
112
	return ;
141
	return;
113
    }
142
    }
114
    s = lub ( s1, s2 ) ;
143
    s = lub(s1, s2);
115
    if ( s == null ) {
144
    if (s == null) {
116
	p->shape = null ;
145
	p->shape = null;
117
    } else {
146
    } else {
118
	long n = s->cons->encoding ;
147
	long n = s->cons->encoding;
119
	if ( n == ENC_bottom || n == ENC_top ) {
148
	if (n == ENC_bottom || n == ENC_top) {
120
	    p->shape = null ;
149
	    p->shape = null;
121
	} else {
150
	} else {
122
	    p->shape = normalize ( s ) ;
151
	    p->shape = normalize(s);
123
	}
152
	}
124
    }
153
    }
125
    return ;
154
    return;
126
}
155
}
127
 
156
 
128
 
157
 
129
/*
158
/*
130
    SHAPE CHECKING FOR OBTAIN_TAG
159
    SHAPE CHECKING FOR OBTAIN_TAG
131
 
160
 
132
    The shape checking for the obtain_tag construct p is implemented by
161
    The shape checking for the obtain_tag construct p is implemented by
133
    this routine.  a gives the actual tag.
162
    this routine.  a gives the actual tag.
134
*/
163
*/
135
 
164
 
136
static void chk_tag
165
static void
137
    PROTO_N ( ( p, a, intro ) )
-
 
138
    PROTO_T ( node *p X node *a X int intro )
166
chk_tag(node *p, node *a, int intro)
139
{
167
{
140
    if ( !intro && a->cons->encoding == ENC_make_tag ) {
168
    if (!intro && a->cons->encoding == ENC_make_tag) {
141
	tag_info *info = get_tag_info ( a->son->cons ) ;
169
	tag_info *info = get_tag_info(a->son->cons);
142
	node *d = info->dec ;
170
	node *d = info->dec;
143
	if ( d && d->cons->sortnum == SORT_completion ) d = d->son ;
171
	if (d && d->cons->sortnum == SORT_completion)d = d->son;
144
	if ( d ) d = d->bro ;
172
	if (d)d = d->bro;
145
	if ( d ) d = d->bro ;
173
	if (d)d = d->bro;
146
	switch ( info->var ) {
174
	switch (info->var) {
147
	    case 0 : {
175
	    case 0: {
148
		p->shape = normalize ( d ) ;
176
		p->shape = normalize(d);
149
		break ;
177
		break;
150
	    }
178
	    }
151
	    case 1 :
179
	    case 1:
152
	    case 2 : {
180
	    case 2: {
153
		p->shape = sh_pointer ( d ) ;
181
		p->shape = sh_pointer(d);
154
		break ;
182
		break;
155
	    }
183
	    }
156
	    default : {
184
	    default : {
157
		if ( text_input ) {
185
		if (text_input) {
158
		    char *nm = a->son->cons->name ;
186
		    char *nm = a->son->cons->name;
159
		    is_fatal = 0 ;
187
		    is_fatal = 0;
160
		    input_error ( "Tag %s used but not declared", nm ) ;
188
		    input_error("Tag %s used but not declared", nm);
161
		}
189
		}
162
		p->shape = null ;
190
		p->shape = null;
163
		break ;
191
		break;
164
	    }
192
	    }
165
	}
193
	}
166
    } else {
194
    } else {
167
	p->shape = null ;
195
	p->shape = null;
168
    }
196
    }
169
    return ;
197
    return;
170
}
198
}
171
 
199
 
172
 
200
 
173
/*
201
/*
174
    SHAPE CHECKING MACRO DEFINITIONS
202
    SHAPE CHECKING MACRO DEFINITIONS
Line 189... Line 217...
189
 
217
 
190
    The construct compound has an exp argument which needs to be
218
    The construct compound has an exp argument which needs to be
191
    shape checked.
219
    shape checked.
192
*/
220
*/
193
 
221
 
194
void check_shape_fn
222
void
195
    PROTO_N ( ( p ) )
-
 
196
    PROTO_T ( node *p )
223
check_shape_fn(node *p)
197
{
224
{
198
    if ( p && p->cons->encoding == ENC_compound ) {
225
    if (p && p->cons->encoding == ENC_compound) {
199
	if ( do_check ) {
226
	if (do_check) {
200
	    checking = p->cons->name ;
227
	    checking = p->cons->name;
201
	    IGNORE check1 ( ENC_offset, p->son ) ;
228
	    IGNORE check1(ENC_offset, p->son);
202
	}
229
	}
203
    }
230
    }
204
    return ;
231
    return;
205
}
232
}
206
 
233
 
207
 
234
 
208
/*
235
/*
209
    SHAPE CHECK A NAT
236
    SHAPE CHECK A NAT
210
 
237
 
211
    The construct computed_nat has an exp argument which needs to be
238
    The construct computed_nat has an exp argument which needs to be
212
    shape checked.
239
    shape checked.
213
*/
240
*/
214
 
241
 
215
void check_nat_fn
242
void
216
    PROTO_N ( ( p ) )
-
 
217
    PROTO_T ( node *p )
243
check_nat_fn(node *p)
218
{
244
{
219
    if ( p && p->cons->encoding == ENC_computed_nat ) {
245
    if (p && p->cons->encoding == ENC_computed_nat) {
220
	if ( do_check ) {
246
	if (do_check) {
221
	    checking = p->cons->name ;
247
	    checking = p->cons->name;
222
	    IGNORE check1 ( ENC_integer, p->son ) ;
248
	    IGNORE check1(ENC_integer, p->son);
223
	}
249
	}
224
    }
250
    }
225
    return ;
251
    return;
226
}
252
}
227
 
253
 
228
 
254
 
229
/*
255
/*
230
    SHAPE CHECK A SIGNED NAT
256
    SHAPE CHECK A SIGNED NAT
231
 
257
 
232
    The construct computed_signed_nat has an exp argument which needs
258
    The construct computed_signed_nat has an exp argument which needs
233
    to be shape checked.
259
    to be shape checked.
234
*/
260
*/
235
 
261
 
236
void check_snat_fn
262
void
237
    PROTO_N ( ( p ) )
-
 
238
    PROTO_T ( node *p )
263
check_snat_fn(node *p)
239
{
264
{
240
    if ( p && p->cons->encoding == ENC_computed_signed_nat ) {
265
    if (p && p->cons->encoding == ENC_computed_signed_nat) {
241
	if ( do_check ) {
266
	if (do_check) {
242
	    checking = p->cons->name ;
267
	    checking = p->cons->name;
243
	    IGNORE check1 ( ENC_integer, p->son ) ;
268
	    IGNORE check1(ENC_integer, p->son);
244
	}
269
	}
245
    }
270
    }
246
    return ;
271
    return;
247
}
272
}
248
 
273
 
249
 
274
 
250
/*
275
/*
251
    SHAPE CHECK AN ACCESS
276
    SHAPE CHECK AN ACCESS
252
 
277
 
253
    The flag intro_visible is set whenever a visible construct is
278
    The flag intro_visible is set whenever a visible construct is
254
    encountered.
279
    encountered.
255
*/
280
*/
256
 
281
 
257
void check_access_fn
282
void
258
    PROTO_N ( ( p ) )
-
 
259
    PROTO_T ( node *p )
283
check_access_fn(node *p)
260
{
284
{
261
    if ( p && p->cons->encoding == ENC_visible ) intro_visible = 1 ;
285
    if (p && p->cons->encoding == ENC_visible)intro_visible = 1;
262
    return ;
286
    return;
263
}
287
}
264
 
288
 
265
 
289
 
266
/*
290
/*
267
    IS A SHAPE COMPLETELY KNOWN?
291
    IS A SHAPE COMPLETELY KNOWN?
Line 269... Line 293...
269
    This routine returns true if p is not null and does not contain
293
    This routine returns true if p is not null and does not contain
270
    any unknown constructs.  In encode mode we can't have any constructs
294
    any unknown constructs.  In encode mode we can't have any constructs
271
    which introduce local tags or tokens either.
295
    which introduce local tags or tokens either.
272
*/
296
*/
273
 
297
 
274
static boolean is_known
298
static boolean
275
    PROTO_N ( ( p ) )
-
 
276
    PROTO_T ( node *p )
299
is_known(node *p)
277
{
300
{
278
    if ( p == null ) return ( 0 ) ;
301
    if (p == null) return(0);
279
    while ( p ) {
302
    while (p) {
280
	sortname s = p->cons->sortnum ;
303
	sortname s = p->cons->sortnum;
281
	if ( s == SORT_unknown ) return ( 0 ) ;
304
	if (s == SORT_unknown) return(0);
282
	if ( !text_output && s == SORT_exp ) {
305
	if (!text_output && s == SORT_exp) {
283
	    switch ( p->cons->encoding ) {
306
	    switch (p->cons->encoding) {
284
		case ENC_conditional : return ( 0 ) ;
307
		case ENC_conditional: return(0);
285
		case ENC_identify : return ( 0 ) ;
308
		case ENC_identify: return(0);
286
		case ENC_labelled : return ( 0 ) ;
309
		case ENC_labelled: return(0);
287
		case ENC_make_proc : return ( 0 ) ;
310
		case ENC_make_proc: return(0);
288
		case ENC_repeat : return ( 0 ) ;
311
		case ENC_repeat: return(0);
289
		case ENC_variable : return ( 0 ) ;
312
		case ENC_variable: return(0);
290
	    }
313
	    }
291
	}
314
	}
292
	if ( p->son && !is_known ( p->son ) ) return ( 0 ) ;
315
	if (p->son && !is_known(p->son)) return(0);
293
	p = p->bro ;
316
	p = p->bro;
294
    }
317
    }
295
    return ( 1 ) ;
318
    return(1);
296
}
319
}
297
 
320
 
298
 
321
 
299
/*
322
/*
300
    CHECK THAT A TAG DECLARATION AND DEFINITION MATCH
323
    CHECK THAT A TAG DECLARATION AND DEFINITION MATCH
301
 
324
 
302
    The construct p, representing a declared and defined tag, is checked
325
    The construct p, representing a declared and defined tag, is checked
303
    for shape correctness.
326
    for shape correctness.
304
*/
327
*/
305
 
328
 
306
void check_tagdef
329
void
307
    PROTO_N ( ( p ) )
-
 
308
    PROTO_T ( construct *p )
330
check_tagdef(construct *p)
309
{
331
{
310
    char *nm = p->name ;
332
    char *nm = p->name;
311
    tag_info *info = get_tag_info ( p ) ;
333
    tag_info *info = get_tag_info(p);
312
    node *dc = info->dec ;
334
    node *dc = info->dec;
313
    node *df = info->def ;
335
    node *df = info->def;
314
    if ( df == null ) return ;
336
    if (df == null) return;
315
    if ( df->cons->sortnum == SORT_completion ) df = df->son ;
337
    if (df->cons->sortnum == SORT_completion)df = df->son;
316
    if ( info->var ) df = df->bro ;
338
    if (info->var)df = df->bro;
317
    if ( dc == null ) {
339
    if (dc == null) {
318
	if ( is_known ( df->shape ) ) {
340
	if (is_known(df->shape)) {
319
	    /* Declaration = ?[u]?[X]S (from 4.0) */
341
	    /* Declaration = ?[u]?[X]S (from 4.0) */
320
	    node *q = new_node () ;
342
	    node *q = new_node();
321
	    q->cons = &false_cons ;
343
	    q->cons = &false_cons;
322
	    q->bro = new_node () ;
344
	    q->bro = new_node();
323
	    q->bro->cons = &false_cons ;
345
	    q->bro->cons = &false_cons;
324
	    q->bro->bro = df->shape ;
346
	    q->bro->bro = df->shape;
325
	    info->dec->bro = completion ( q ) ;
347
	    info->dec->bro = completion(q);
326
	} else {
348
	} else {
327
	    is_fatal = 0 ;
349
	    is_fatal = 0;
328
	    input_error ( "Can't deduce shape of %s from definition", nm ) ;
350
	    input_error("Can't deduce shape of %s from definition", nm);
329
	}
351
	}
330
    } else {
352
    } else {
331
	if ( dc->cons->sortnum == SORT_completion ) dc = dc->son ;
353
	if (dc->cons->sortnum == SORT_completion)dc = dc->son;
332
	/* Declaration = ?[u]?[X]S (from 4.0) */
354
	/* Declaration = ?[u]?[X]S (from 4.0) */
333
	dc = dc->bro->bro ;
355
	dc = dc->bro->bro;
334
	checking = nm ;
356
	checking = nm;
335
	IGNORE check_shapes ( dc, df->shape, 1 ) ;
357
	IGNORE check_shapes(dc, df->shape, 1);
336
    }
358
    }
337
    return ;
359
    return;
338
}
360
}