Subversion Repositories tendra.SVN

Rev

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

Rev 5 Rev 6
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 47... Line 77...
47
    not in this list, or with a sort code of zero, have sort codes
77
    not in this list, or with a sort code of zero, have sort codes
48
    automatically generated for them.
78
    automatically generated for them.
49
*/
79
*/
50
 
80
 
51
static struct {
81
static struct {
52
    char *name ;
82
    char *name;
53
    int code ;
83
    int code;
54
} sort_names [] = {
84
} sort_names[] = {
55
    /* Built-in sorts */
85
    /* Built-in sorts */
56
    { "tdfint", 'i' },
86
    { "tdfint", 'i' },
57
    { "tdfstring", '$' },
87
    { "tdfstring", '$' },
58
    { "tdfident", '=' },
88
    { "tdfident", '=' },
59
    { "tdfbool", 'j' },
89
    { "tdfbool", 'j' },
Line 128... Line 158...
128
    { "dg_tag", 'J' },
158
    { "dg_tag", 'J' },
129
    { "dg_type", 0 },
159
    { "dg_type", 0 },
130
    { "dg_variant", 0 },
160
    { "dg_variant", 0 },
131
    { "dg_varpart", 0 },
161
    { "dg_varpart", 0 },
132
    { "dg_virtuality", 0 }
162
    { "dg_virtuality", 0 }
133
} ;
163
};
134
 
164
 
135
#define NO_BUILTIN_SORTS	6
165
#define NO_BUILTIN_SORTS	6
136
#define NO_SORTS		array_size ( sort_names )
166
#define NO_SORTS		array_size(sort_names)
137
 
167
 
138
 
168
 
139
/*
169
/*
140
    LIST OF ALL SORTS
170
    LIST OF ALL SORTS
141
 
171
 
142
    A list of all sorts (in alphabetical order) is maintained.
172
    A list of all sorts (in alphabetical order) is maintained.
143
*/
173
*/
144
 
174
 
145
static LIST ( SORT ) all_sorts = NULL_list ( SORT ) ;
175
static LIST(SORT)all_sorts = NULL_list(SORT);
146
 
176
 
147
 
177
 
148
/*
178
/*
149
    DEFINE A SORT
179
    DEFINE A SORT
150
 
180
 
151
    This routine defines the sort s to be info.
181
    This routine defines the sort s to be info.
152
*/
182
*/
153
 
183
 
154
static void define_sort
184
static void
155
    PROTO_N ( ( s, info, code ) )
-
 
156
    PROTO_T ( SORT s X SORT_INFO info X int code )
185
define_sort(SORT s, SORT_INFO info, int code)
157
{
186
{
158
    static int next_code = 1 ;
187
    static int next_code = 1;
159
    SORT_INFO old = DEREF_info ( sort_info ( s ) ) ;
188
    SORT_INFO old = DEREF_info(sort_info(s));
160
    if ( !IS_NULL_info ( old ) ) {
189
    if (!IS_NULL_info(old)) {
161
	string nm = DEREF_string ( sort_name ( s ) ) ;
190
	string nm = DEREF_string(sort_name(s));
162
	error ( ERROR_SERIOUS, "Sort '%s' already defined", nm ) ;
191
	error(ERROR_SERIOUS, "Sort '%s' already defined", nm);
163
    }
192
    }
164
    COPY_info ( sort_info ( s ), info ) ;
193
    COPY_info(sort_info(s), info);
165
    if ( code == 0 ) code = next_code++ ;
194
    if (code == 0) code = next_code++;
166
    COPY_int ( sort_code ( s ), code ) ;
195
    COPY_int(sort_code(s), code);
167
    return ;
196
    return;
168
}
197
}
169
 
198
 
170
 
199
 
171
/*
200
/*
172
    FIND A SORT
201
    FIND A SORT
173
 
202
 
174
    This routine looks up a sort named nm, creating it if it does not
203
    This routine looks up a sort named nm, creating it if it does not
175
    already exist if create is true.
204
    already exist if create is true.
176
*/
205
*/
177
 
206
 
178
SORT find_sort
207
SORT
179
    PROTO_N ( ( nm, create ) )
-
 
180
    PROTO_T ( string nm X int create )
208
find_sort(string nm, int create)
181
{
209
{
182
    SORT s ;
210
    SORT s;
183
    string cnm ;
211
    string cnm;
184
    SORT_INFO info = NULL_info ;
212
    SORT_INFO info = NULL_info;
185
    LIST ( SORT ) p = all_sorts ;
213
    LIST(SORT)p = all_sorts;
186
    LIST ( SORT ) q = NULL_list ( SORT ) ;
214
    LIST(SORT)q = NULL_list(SORT);
187
    while ( !IS_NULL_list ( p ) ) {
215
    while (!IS_NULL_list(p)) {
188
	int cmp ;
216
	int cmp;
189
	string n ;
217
	string n;
190
	s = DEREF_sort ( HEAD_list ( p ) ) ;
218
	s = DEREF_sort(HEAD_list(p));
191
	n = DEREF_string ( sort_name ( s ) ) ;
219
	n = DEREF_string(sort_name(s));
192
	cmp = strcmp ( n, nm ) ;
220
	cmp = strcmp(n, nm);
193
	if ( cmp == 0 ) return ( s ) ;
221
	if (cmp == 0) return(s);
194
	if ( cmp > 0 ) break ;
222
	if (cmp > 0) break;
195
	q = p ;
223
	q = p;
196
	p = TAIL_list ( p ) ;
224
	p = TAIL_list(p);
197
    }
225
    }
198
    cnm = to_capitals ( nm ) ;
226
    cnm = to_capitals(nm);
199
    MAKE_sort_basic ( nm, cnm, NULL, NULL, 0, 0, 0, 0, info, s ) ;
227
    MAKE_sort_basic(nm, cnm, NULL, NULL, 0, 0, 0, 0, info, s);
200
    if ( !create ) {
228
    if (!create) {
201
	error ( ERROR_SERIOUS, "Sort '%s' not defined", nm ) ;
229
	error(ERROR_SERIOUS, "Sort '%s' not defined", nm);
202
	MAKE_info_builtin ( nm, info ) ;
230
	MAKE_info_builtin(nm, info);
203
	define_sort ( s, info, 0 ) ;
231
	define_sort(s, info, 0);
204
    }
232
    }
205
    CONS_sort ( s, p, p ) ;
233
    CONS_sort(s, p, p);
206
    if ( IS_NULL_list ( q ) ) {
234
    if (IS_NULL_list(q)) {
207
	all_sorts = p ;
235
	all_sorts = p;
208
    } else {
236
    } else {
209
	COPY_list ( PTR_TAIL_list ( q ), p ) ;
237
	COPY_list(PTR_TAIL_list(q), p);
210
    }
238
    }
211
    return ( s ) ;
239
    return(s);
212
}
240
}
213
 
241
 
214
 
242
 
215
/*
243
/*
216
    MARK A CONSTRUCT AS USED
244
    MARK A CONSTRUCT AS USED
217
 
245
 
218
    This routine marks the parameter sorts of the constructs c with the
246
    This routine marks the parameter sorts of the constructs c with the
219
    value m.
247
    value m.
220
*/
248
*/
221
 
249
 
222
void mark_construct
250
void
223
    PROTO_N ( ( c, m ) )
-
 
224
    PROTO_T ( CONSTRUCT c X int m )
251
mark_construct(CONSTRUCT c, int m)
225
{
252
{
226
    if ( !IS_NULL_cons ( c ) ) {
253
    if (!IS_NULL_cons(c)) {
227
	LIST ( PARAMETER ) p = DEREF_list ( cons_pars ( c ) ) ;
254
	LIST(PARAMETER)p = DEREF_list(cons_pars(c));
228
	while ( !IS_NULL_list ( p ) ) {
255
	while (!IS_NULL_list(p)) {
229
	    PARAMETER a = DEREF_par ( HEAD_list ( p ) ) ;
256
	    PARAMETER a = DEREF_par(HEAD_list(p));
230
	    SORT s = DEREF_sort ( par_type ( a ) ) ;
257
	    SORT s = DEREF_sort(par_type(a));
231
	    mark_sort ( s, m ) ;
258
	    mark_sort(s, m);
232
	    p = TAIL_list ( p ) ;
259
	    p = TAIL_list(p);
233
	}
260
	}
234
    }
261
    }
235
    return ;
262
    return;
236
}
263
}
237
 
264
 
238
 
265
 
239
/*
266
/*
240
    MARK A SORT AS USED
267
    MARK A SORT AS USED
241
 
268
 
242
    This routine marks the sort s and all its constructs with the value m.
269
    This routine marks the sort s and all its constructs with the value m.
243
*/
270
*/
244
 
271
 
245
void mark_sort
272
void
246
    PROTO_N ( ( s, m ) )
-
 
247
    PROTO_T ( SORT s X int m )
273
mark_sort(SORT s, int m)
248
{
274
{
249
    int mark = DEREF_int ( sort_mark ( s ) ) ;
275
    int mark = DEREF_int(sort_mark(s));
250
    if ( mark != m ) {
276
    if (mark != m) {
251
	SORT_INFO info = DEREF_info ( sort_info ( s ) ) ;
277
	SORT_INFO info = DEREF_info(sort_info(s));
252
	COPY_int ( sort_mark ( s ), m ) ;
278
	COPY_int(sort_mark(s), m);
253
	if ( !IS_NULL_info ( info ) ) {
279
	if (!IS_NULL_info(info)) {
254
	    switch ( TAG_info ( info ) ) {
280
	    switch (TAG_info(info)) {
255
		case info_basic_tag : {
281
		case info_basic_tag: {
256
		    LIST ( CONSTRUCT ) p ;
282
		    LIST(CONSTRUCT)p;
257
		    p = DEREF_list ( info_basic_cons ( info ) ) ;
283
		    p = DEREF_list(info_basic_cons(info));
258
		    while ( !IS_NULL_list ( p ) ) {
284
		    while (!IS_NULL_list(p)) {
259
			CONSTRUCT c = DEREF_cons ( HEAD_list ( p ) ) ;
285
			CONSTRUCT c = DEREF_cons(HEAD_list(p));
260
			mark_construct ( c, m ) ;
286
			mark_construct(c, m);
261
			p = TAIL_list ( p ) ;
287
			p = TAIL_list(p);
262
		    }
288
		    }
263
		    break ;
289
		    break;
264
		}
290
		}
265
		case info_dummy_tag : {
291
		case info_dummy_tag: {
266
		    CONSTRUCT c = DEREF_cons ( info_dummy_cons ( info ) ) ;
292
		    CONSTRUCT c = DEREF_cons(info_dummy_cons(info));
267
		    mark_construct ( c, m ) ;
293
		    mark_construct(c, m);
268
		    break ;
294
		    break;
269
		}
295
		}
270
		case info_clist_tag :
296
		case info_clist_tag:
271
		case info_slist_tag :
297
		case info_slist_tag:
272
		case info_option_tag : {
298
		case info_option_tag: {
273
		    SORT p = DEREF_sort ( info_clist_etc_arg ( info ) ) ;
299
		    SORT p = DEREF_sort(info_clist_etc_arg(info));
274
		    mark_sort ( p, m ) ;
300
		    mark_sort(p, m);
275
		    break ;
301
		    break;
276
		}
302
		}
277
	    }
303
	    }
278
	}
304
	}
279
    }
305
    }
280
    return ;
306
    return;
281
}
307
}
282
 
308
 
283
 
309
 
284
/*
310
/*
285
    MARK ALL SORTS AS USED
311
    MARK ALL SORTS AS USED
286
 
312
 
287
    This routine marks all sorts with the value m.
313
    This routine marks all sorts with the value m.
288
*/
314
*/
289
 
315
 
290
void mark_all_sorts
316
void
291
    PROTO_N ( ( m ) )
-
 
292
    PROTO_T ( int m )
317
mark_all_sorts(int m)
293
{
318
{
294
    LIST ( SORT ) p = all_sorts ;
319
    LIST(SORT)p = all_sorts;
295
    while ( !IS_NULL_list ( p ) ) {
320
    while (!IS_NULL_list(p)) {
296
	SORT s = DEREF_sort ( HEAD_list ( p ) ) ;
321
	SORT s = DEREF_sort(HEAD_list(p));
297
	COPY_int ( sort_mark ( s ), m ) ;
322
	COPY_int(sort_mark(s), m);
298
	p = TAIL_list ( p ) ;
323
	p = TAIL_list(p);
299
    }
324
    }
300
    return ;
325
    return;
301
}
326
}
302
 
327
 
303
 
328
 
304
/*
329
/*
305
    DOES A STRING HAVE A GIVEN ENDING?
330
    DOES A STRING HAVE A GIVEN ENDING?
Line 307... Line 332...
307
    This routine checks whether the string s ends in the string e.  If so
332
    This routine checks whether the string s ends in the string e.  If so
308
    it returns a copy of s with this ending removed.  Otherwise it returns
333
    it returns a copy of s with this ending removed.  Otherwise it returns
309
    the null string.
334
    the null string.
310
*/
335
*/
311
 
336
 
312
string ends_in
337
string
313
    PROTO_N ( ( s, e ) )
-
 
314
    PROTO_T ( string s X string e )
338
ends_in(string s, string e)
315
{
339
{
316
    unsigned n = ( unsigned ) strlen ( s ) ;
340
    unsigned n = (unsigned)strlen(s);
317
    unsigned m = ( unsigned ) strlen ( e ) ;
341
    unsigned m = (unsigned)strlen(e);
318
    if ( n >= m ) {
342
    if (n >= m) {
319
	unsigned d = n - m ;
343
	unsigned d = n - m;
320
	if ( streq ( s + d, e ) ) {
344
	if (streq(s + d, e)) {
321
	    s = xstrcpy ( s ) ;
345
	    s = xstrcpy(s);
322
	    s [d] = 0 ;
346
	    s[d] = 0;
323
	    return ( s ) ;
347
	    return(s);
324
	}
348
	}
325
    }
349
    }
326
    return ( NULL ) ;
350
    return(NULL);
327
}
351
}
328
 
352
 
329
 
353
 
330
/*
354
/*
331
    CONVERT A STRING TO CAPITALS
355
    CONVERT A STRING TO CAPITALS
332
 
356
 
333
    This routine returns a copy of the string s with all the lower case
357
    This routine returns a copy of the string s with all the lower case
334
    letters converted to upper case.
358
    letters converted to upper case.
335
*/
359
*/
336
 
360
 
337
string to_capitals
361
string
338
    PROTO_N ( ( s ) )
-
 
339
    PROTO_T ( string s )
362
to_capitals(string s)
340
{
363
{
341
    char c ;
364
    char c;
342
    string t ;
365
    string t;
343
    s = xstrcpy ( s ) ;
366
    s = xstrcpy(s);
344
    t = s ;
367
    t = s;
345
    while ( c = *t, c != 0 ) {
368
    while (c = *t, c != 0) {
346
	if ( c >= 'a' && c <= 'z' ) {
369
	if (c >= 'a' && c <= 'z') {
347
	    *t = ( char ) ( 'A' + ( c - 'a' ) ) ;
370
	    *t = (char)('A' + (c - 'a'));
348
	}
371
	}
349
	t++ ;
372
	t++;
350
    }
373
    }
351
    return ( s ) ;
374
    return(s);
352
}
375
}
353
 
376
 
354
 
377
 
355
/*
378
/*
356
    DEFINE A BASIC SORT
379
    DEFINE A BASIC SORT
357
 
380
 
358
    This routine defines the basic sort s to have b bits (extended if e
381
    This routine defines the basic sort s to have b bits (extended if e
359
    is true) and constructs p.
382
    is true) and constructs p.
360
*/
383
*/
361
 
384
 
362
void basic_sort
385
void
363
    PROTO_N ( ( s, b, e, p ) )
-
 
364
    PROTO_T ( SORT s X unsigned b X unsigned e X LIST ( CONSTRUCT ) p )
386
basic_sort(SORT s, unsigned b, unsigned e, LIST(CONSTRUCT)p)
365
{
387
{
366
    int code = 0 ;
388
    int code = 0;
367
    SORT_INFO info ;
389
    SORT_INFO info;
368
    string n = DEREF_string ( sort_name ( s ) ) ;
390
    string n = DEREF_string(sort_name(s));
369
    if ( b == 0 && e == 0 && LENGTH_list ( p ) == 1 ) {
391
    if (b == 0 && e == 0 && LENGTH_list(p) == 1) {
370
	/* Dummy sort */
392
	/* Dummy sort */
371
	CONSTRUCT c = DEREF_cons ( HEAD_list ( p ) ) ;
393
	CONSTRUCT c = DEREF_cons(HEAD_list(p));
372
	MAKE_info_dummy ( n, c, info ) ;
394
	MAKE_info_dummy(n, c, info);
373
	code = 'F' ;
395
	code = 'F';
374
    } else {
396
    } else {
375
	int i ;
397
	int i;
376
	for ( i = NO_BUILTIN_SORTS ; i < NO_SORTS ; i++ ) {
398
	for (i = NO_BUILTIN_SORTS; i < NO_SORTS; i++) {
377
	    if ( streq ( n, sort_names [i].name ) ) {
399
	    if (streq(n, sort_names[i].name)) {
378
		code = sort_names [i].code ;
400
		code = sort_names[i].code;
379
		break ;
401
		break;
380
	    }
402
	    }
381
	}
403
	}
382
	MAKE_info_basic ( n, b, e, 0, p, NULL_cons, info ) ;
404
	MAKE_info_basic(n, b, e, 0, p, NULL_cons, info);
383
    }
405
    }
384
    define_sort ( s, info, code ) ;
406
    define_sort(s, info, code);
385
    return ;
407
    return;
386
}
408
}
387
 
409
 
388
 
410
 
389
/*
411
/*
390
    CREATE A CONSTRUCT
412
    CREATE A CONSTRUCT
391
 
413
 
392
    This routine creates a construct named nm with result sort s, parameter
414
    This routine creates a construct named nm with result sort s, parameter
393
    sorts p and encoding e.
415
    sorts p and encoding e.
394
*/
416
*/
395
 
417
 
396
CONSTRUCT make_construct
418
CONSTRUCT
397
    PROTO_N ( ( nm, e, s, p ) )
-
 
398
    PROTO_T ( string nm X unsigned e X SORT s X LIST ( PARAMETER ) p )
419
make_construct(string nm, unsigned e, SORT s, LIST(PARAMETER)p)
399
{
420
{
400
    CONSTRUCT c ;
421
    CONSTRUCT c;
401
    unsigned kind = KIND_simple ;
422
    unsigned kind = KIND_simple;
402
    if ( ends_in ( nm, "_apply_token" ) ) kind = KIND_token ;
423
    if (ends_in(nm, "_apply_token")) kind = KIND_token;
403
    if ( ends_in ( nm, "_cond" ) ) kind = KIND_cond ;
424
    if (ends_in(nm, "_cond")) kind = KIND_cond;
404
    MAKE_cons_basic ( nm, e, s, p, kind, c ) ;
425
    MAKE_cons_basic(nm, e, s, p, kind, c);
405
    return ( c ) ;
426
    return(c);
406
}
427
}
407
 
428
 
408
 
429
 
409
/*
430
/*
410
    DEFINE A COMPOUND SORT
431
    DEFINE A COMPOUND SORT
411
 
432
 
412
    This routine defines the compound sort s with standard suffix suff
433
    This routine defines the compound sort s with standard suffix suff
413
    and sort type tag.
434
    and sort type tag.
414
*/
435
*/
415
 
436
 
416
void compound_sort
437
void
417
    PROTO_N ( ( s, suff, tag, code ) )
-
 
418
    PROTO_T ( SORT s X string suff X unsigned tag X int code )
438
compound_sort(SORT s, string suff, unsigned tag, int code)
419
{
439
{
420
    string nm = DEREF_string ( sort_name ( s ) ) ;
440
    string nm = DEREF_string(sort_name(s));
421
    string snm = ends_in ( nm, suff ) ;
441
    string snm = ends_in(nm, suff);
422
    if ( snm ) {
442
    if (snm) {
423
	SORT_INFO info ;
443
	SORT_INFO info;
424
	SORT t = find_sort ( snm, 1 ) ;
444
	SORT t = find_sort(snm, 1);
425
	MAKE_info_clist_etc ( tag, nm, t, info ) ;
445
	MAKE_info_clist_etc(tag, nm, t, info);
426
	define_sort ( s, info, code ) ;
446
	define_sort(s, info, code);
427
    } else {
447
    } else {
428
	error ( ERROR_SERIOUS, "Sort '%s' doesn't end in '%s'", nm, suff ) ;
448
	error(ERROR_SERIOUS, "Sort '%s' doesn't end in '%s'", nm, suff);
429
    }
449
    }
430
    return ;
450
    return;
431
}
451
}
432
 
452
 
433
 
453
 
434
/*
454
/*
435
    FIND A CONSTRUCT
455
    FIND A CONSTRUCT
436
 
456
 
437
    This routine searches for a construct named c in the sort s.
457
    This routine searches for a construct named c in the sort s.
438
*/
458
*/
439
 
459
 
440
CONSTRUCT find_construct
460
CONSTRUCT
441
    PROTO_N ( ( s, c ) )
-
 
442
    PROTO_T ( SORT s X string c )
461
find_construct(SORT s, string c)
443
{
462
{
444
    SORT_INFO info = DEREF_info ( sort_info ( s ) ) ;
463
    SORT_INFO info = DEREF_info(sort_info(s));
445
    if ( !IS_NULL_info ( info ) && IS_info_basic ( info ) ) {
464
    if (!IS_NULL_info(info) && IS_info_basic(info)) {
446
	LIST ( CONSTRUCT ) p = DEREF_list ( info_basic_cons ( info ) ) ;
465
	LIST(CONSTRUCT)p = DEREF_list(info_basic_cons(info));
447
	while ( !IS_NULL_list ( p ) ) {
466
	while (!IS_NULL_list(p)) {
448
	    CONSTRUCT a = DEREF_cons ( HEAD_list ( p ) ) ;
467
	    CONSTRUCT a = DEREF_cons(HEAD_list(p));
449
	    string b = DEREF_string ( cons_name ( a ) ) ;
468
	    string b = DEREF_string(cons_name(a));
450
	    if ( streq ( b, c ) ) return ( a ) ;
469
	    if (streq(b, c)) return(a);
451
	    p = TAIL_list ( p ) ;
470
	    p = TAIL_list(p);
452
	}
471
	}
453
    }
472
    }
454
    return ( NULL_cons ) ;
473
    return(NULL_cons);
455
}
474
}
456
 
475
 
457
 
476
 
458
/*
477
/*
459
    SET A CONSTRUCT KIND
478
    SET A CONSTRUCT KIND
460
 
479
 
461
    This routine sets the kind of the construct c of sort s to be kind.
480
    This routine sets the kind of the construct c of sort s to be kind.
462
*/
481
*/
463
 
482
 
464
void set_special
483
void
465
    PROTO_N ( ( s, c, kind ) )
-
 
466
    PROTO_T ( SORT s X string c X unsigned kind )
484
set_special(SORT s, string c, unsigned kind)
467
{
485
{
468
    CONSTRUCT a = find_construct ( s, c ) ;
486
    CONSTRUCT a = find_construct(s, c);
469
    if ( !IS_NULL_cons ( a ) ) {
487
    if (!IS_NULL_cons(a)) {
470
	COPY_unsigned ( cons_kind ( a ), kind ) ;
488
	COPY_unsigned(cons_kind(a), kind);
471
    } else {
489
    } else {
472
	string nm = DEREF_string ( sort_name ( s ) ) ;
490
	string nm = DEREF_string(sort_name(s));
473
	error ( ERROR_SERIOUS, "Can't find construct '%s' for sort '%s'",
491
	error(ERROR_SERIOUS, "Can't find construct '%s' for sort '%s'",
474
		c, nm ) ;
492
		c, nm);
475
    }
493
    }
476
    return ;
494
    return;
477
}
495
}
478
 
496
 
479
 
497
 
480
/*
498
/*
481
    FIND A CONSTRUCT OF A GIVEN KIND
499
    FIND A CONSTRUCT OF A GIVEN KIND
482
 
500
 
483
    This routine searches for a construct of the sort s of the given kind.
501
    This routine searches for a construct of the sort s of the given kind.
484
*/
502
*/
485
 
503
 
486
CONSTRUCT get_special
504
CONSTRUCT
487
    PROTO_N ( ( s, kind ) )
-
 
488
    PROTO_T ( SORT s X unsigned kind )
505
get_special(SORT s, unsigned kind)
489
{
506
{
490
    SORT_INFO info = DEREF_info ( sort_info ( s ) ) ;
507
    SORT_INFO info = DEREF_info(sort_info(s));
491
    if ( !IS_NULL_info ( info ) && IS_info_basic ( info ) ) {
508
    if (!IS_NULL_info(info) && IS_info_basic(info)) {
492
	LIST ( CONSTRUCT ) p = DEREF_list ( info_basic_cons ( info ) ) ;
509
	LIST(CONSTRUCT)p = DEREF_list(info_basic_cons(info));
493
	while ( !IS_NULL_list ( p ) ) {
510
	while (!IS_NULL_list(p)) {
494
	    CONSTRUCT a = DEREF_cons ( HEAD_list ( p ) ) ;
511
	    CONSTRUCT a = DEREF_cons(HEAD_list(p));
495
	    unsigned b = DEREF_unsigned ( cons_kind ( a ) ) ;
512
	    unsigned b = DEREF_unsigned(cons_kind(a));
496
	    if ( b == kind ) return ( a ) ;
513
	    if (b == kind) return(a);
497
	    p = TAIL_list ( p ) ;
514
	    p = TAIL_list(p);
498
	}
515
	}
499
    }
516
    }
500
    return ( NULL_cons ) ;
517
    return(NULL_cons);
501
}
518
}
502
 
519
 
503
 
520
 
504
/*
521
/*
505
    DEFINE THE BUILT-IN SORTS
522
    DEFINE THE BUILT-IN SORTS
506
 
523
 
507
    This routine defines the built-in sorts.
524
    This routine defines the built-in sorts.
508
*/
525
*/
509
 
526
 
510
void builtin_sorts
527
void
511
    PROTO_Z ()
528
builtin_sorts(void)
512
{
529
{
513
    int i ;
530
    int i;
514
    for ( i = 0 ; i < NO_BUILTIN_SORTS ; i++ ) {
531
    for (i = 0; i < NO_BUILTIN_SORTS; i++) {
515
	SORT_INFO info ;
532
	SORT_INFO info;
516
	char *nm = sort_names [i].name ;
533
	char *nm = sort_names[i].name;
517
	SORT s = find_sort ( nm, 1 ) ;
534
	SORT s = find_sort(nm, 1);
518
	MAKE_info_builtin ( nm, info ) ;
535
	MAKE_info_builtin(nm, info);
519
	define_sort ( s, info, sort_names [i].code ) ;
536
	define_sort(s, info, sort_names[i].code);
520
    }
537
    }
521
    return ;
538
    return;
522
}
539
}
523
 
540
 
524
 
541
 
525
/*
542
/*
526
    CHECK THE LIST OF ALL SORTS
543
    CHECK THE LIST OF ALL SORTS
527
 
544
 
528
    This routine checks the list of all sorts for undefined sorts,
545
    This routine checks the list of all sorts for undefined sorts,
529
    returning the reordered list.
546
    returning the reordered list.
530
*/
547
*/
531
 
548
 
532
LIST ( SORT ) check_sorts
549
LIST(SORT)
533
    PROTO_Z ()
550
check_sorts(void)
534
{
551
{
535
    LIST ( SORT ) p = all_sorts ;
552
    LIST(SORT)p = all_sorts;
536
    while ( !IS_NULL_list ( p ) ) {
553
    while (!IS_NULL_list(p)) {
537
	SORT s = DEREF_sort ( HEAD_list ( p ) ) ;
554
	SORT s = DEREF_sort(HEAD_list(p));
538
	SORT_INFO info = DEREF_info ( sort_info ( s ) ) ;
555
	SORT_INFO info = DEREF_info(sort_info(s));
539
	if ( IS_NULL_info ( info ) ) {
556
	if (IS_NULL_info(info)) {
540
	    string nm = DEREF_string ( sort_name ( s ) ) ;
557
	    string nm = DEREF_string(sort_name(s));
541
	    error ( ERROR_SERIOUS, "Sort '%s' not defined", nm ) ;
558
	    error(ERROR_SERIOUS, "Sort '%s' not defined", nm);
542
	    MAKE_info_builtin ( nm, info ) ;
559
	    MAKE_info_builtin(nm, info);
543
	    define_sort ( s, info, 0 ) ;
560
	    define_sort(s, info, 0);
544
	}
561
	}
545
	if ( IS_info_basic ( info ) ) {
562
	if (IS_info_basic(info)) {
546
	    unsigned m = 0 ;
563
	    unsigned m = 0;
547
	    LIST ( CONSTRUCT ) q = DEREF_list ( info_basic_cons ( info ) ) ;
564
	    LIST(CONSTRUCT)q = DEREF_list(info_basic_cons(info));
548
	    while ( !IS_NULL_list ( q ) ) {
565
	    while (!IS_NULL_list(q)) {
549
		CONSTRUCT a = DEREF_cons ( HEAD_list ( q ) ) ;
566
		CONSTRUCT a = DEREF_cons(HEAD_list(q));
550
		unsigned n = DEREF_unsigned ( cons_encode ( a ) ) ;
567
		unsigned n = DEREF_unsigned(cons_encode(a));
551
		if ( n > m ) m = n ;
568
		if (n > m) m = n;
552
		q = TAIL_list ( q ) ;
569
		q = TAIL_list(q);
553
	    }
570
	    }
554
	    COPY_unsigned ( info_basic_max ( info ), m ) ;
571
	    COPY_unsigned(info_basic_max(info), m);
555
	}
572
	}
556
	p = TAIL_list ( p ) ;
573
	p = TAIL_list(p);
557
    }
574
    }
558
    return ( all_sorts ) ;
575
    return(all_sorts);
559
}
576
}
560
 
577
 
561
 
578
 
562
/*
579
/*
563
    FIND FOREIGN SORTS
580
    FIND FOREIGN SORTS
564
 
581
 
565
    This routine finds all the foreign sorts.
582
    This routine finds all the foreign sorts.
566
*/
583
*/
567
 
584
 
568
LIST ( LINKAGE ) foreign_sorts
585
LIST(LINKAGE)
569
    PROTO_Z ()
586
foreign_sorts(void)
570
{
587
{
571
    unsigned e = 0 ;
588
    unsigned e = 0;
572
    LIST ( SORT ) p = all_sorts ;
589
    LIST(SORT)p = all_sorts;
573
    LIST ( LINKAGE ) q = NULL_list ( LINKAGE ) ;
590
    LIST(LINKAGE)q = NULL_list(LINKAGE);
574
    LIST ( PARAMETER ) pars = NULL_list ( PARAMETER ) ;
591
    LIST(PARAMETER)pars = NULL_list(PARAMETER);
575
    SORT t = find_sort ( "sortname", 0 ) ;
592
    SORT t = find_sort("sortname", 0);
576
    SORT_INFO info = DEREF_info ( sort_info ( t ) ) ;
593
    SORT_INFO info = DEREF_info(sort_info(t));
577
    if ( IS_info_basic ( info ) ) {
594
    if (IS_info_basic(info)) {
578
	e = DEREF_unsigned ( info_basic_max ( info ) ) ;
595
	e = DEREF_unsigned(info_basic_max(info));
579
    }
596
    }
580
    while ( !IS_NULL_list ( p ) ) {
597
    while (!IS_NULL_list(p)) {
581
	SORT s = DEREF_sort ( HEAD_list ( p ) ) ;
598
	SORT s = DEREF_sort(HEAD_list(p));
582
	info = DEREF_info ( sort_info ( s ) ) ;
599
	info = DEREF_info(sort_info(s));
583
	if ( IS_info_basic ( info ) ) {
600
	if (IS_info_basic(info)) {
584
	    string nm = DEREF_string ( sort_name ( s ) ) ;
601
	    string nm = DEREF_string(sort_name(s));
585
	    CONSTRUCT c = get_special ( s, KIND_token ) ;
602
	    CONSTRUCT c = get_special(s, KIND_token);
586
	    if ( !IS_NULL_cons ( c ) ) {
603
	    if (!IS_NULL_cons(c)) {
587
		/* Sort can be tokenised */
604
		/* Sort can be tokenised */
588
		string snm = nm ;
605
		string snm = nm;
589
		if ( streq ( nm, "alignment" ) ) {
606
		if (streq(nm, "alignment")) {
590
		    snm = "alignment_sort" ;
607
		    snm = "alignment_sort";
591
		}
608
		}
592
		c = find_construct ( t, snm ) ;
609
		c = find_construct(t, snm);
593
		if ( IS_NULL_cons ( c ) ) {
610
		if (IS_NULL_cons(c)) {
594
		    /* Doesn't have a sort name */
611
		    /* Doesn't have a sort name */
595
		    LINKAGE a ;
612
		    LINKAGE a;
596
		    if ( streq ( nm, "diag_type" ) ) {
613
		    if (streq(nm, "diag_type")) {
597
			snm = "diag_type" ;
614
			snm = "diag_type";
598
		    } else if ( streq ( nm, "filename" ) ) {
615
		    } else if (streq(nm, "filename")) {
599
			snm = "~diag_file" ;
616
			snm = "~diag_file";
600
		    } else {
617
		    } else {
601
			snm = to_capitals ( nm ) ;
618
			snm = to_capitals(nm);
602
		    }
619
		    }
603
		    MAKE_cons_basic ( snm, ++e, t, pars, KIND_foreign, c ) ;
620
		    MAKE_cons_basic(snm, ++e, t, pars, KIND_foreign, c);
604
		    MAKE_link_basic ( snm, s, a ) ;
621
		    MAKE_link_basic(snm, s, a);
605
		    CONS_link ( a, q, q ) ;
622
		    CONS_link(a, q, q);
606
		}
623
		}
607
	    } else {
624
	    } else {
608
		MAKE_cons_basic ( nm, ++e, t, pars, KIND_dummy, c ) ;
625
		MAKE_cons_basic(nm, ++e, t, pars, KIND_dummy, c);
609
	    }
626
	    }
610
	    COPY_cons ( info_basic_sortname ( info ), c ) ;
627
	    COPY_cons(info_basic_sortname(info), c);
611
	}
628
	}
612
	p = TAIL_list ( p ) ;
629
	p = TAIL_list(p);
613
    }
630
    }
614
    q = REVERSE_list ( q ) ;
631
    q = REVERSE_list(q);
615
    return ( q ) ;
632
    return(q);
616
}
633
}
617
 
634
 
618
 
635
 
619
/*
636
/*
620
    FIND A PARAMETER
637
    FIND A PARAMETER
621
 
638
 
622
    This routine returns the nth parameter of the construct c.
639
    This routine returns the nth parameter of the construct c.
623
*/
640
*/
624
 
641
 
625
PARAMETER find_param
642
PARAMETER
626
    PROTO_N ( ( c, n ) )
-
 
627
    PROTO_T ( CONSTRUCT c X unsigned n )
643
find_param(CONSTRUCT c, unsigned n)
628
{
644
{
629
    LIST ( PARAMETER ) p = DEREF_list ( cons_pars ( c ) ) ;
645
    LIST(PARAMETER)p = DEREF_list(cons_pars(c));
630
    while ( n ) {
646
    while (n) {
631
	if ( IS_NULL_list ( p ) ) {
647
	if (IS_NULL_list(p)) {
632
	    string nm = DEREF_string ( cons_name ( c ) ) ;
648
	    string nm = DEREF_string(cons_name(c));
633
	    error ( ERROR_SERIOUS, "Bad parameter number for '%s'", nm ) ;
649
	    error(ERROR_SERIOUS, "Bad parameter number for '%s'", nm);
634
	    return ( NULL_par ) ;
650
	    return(NULL_par);
635
	}
651
	}
636
	p = TAIL_list ( p ) ;
652
	p = TAIL_list(p);
637
	n-- ;
653
	n--;
638
    }
654
    }
639
    return ( DEREF_par ( HEAD_list ( p ) ) ) ;
655
    return(DEREF_par(HEAD_list(p)));
640
}
656
}