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 45... Line 75...
45
 
75
 
46
    This routine reads n bits.  If these are nonzero they give the result.
76
    This routine reads n bits.  If these are nonzero they give the result.
47
    Otherwise the result is ( 2^n - 1 ) plus the next extended number.
77
    Otherwise the result is ( 2^n - 1 ) plus the next extended number.
48
*/
78
*/
49
 
79
 
50
long fetch_extn
80
long
51
    PROTO_N ( ( n ) )
-
 
52
    PROTO_T ( int n )
81
fetch_extn(int n)
53
{
82
{
54
    long r = 0, s ;
83
    long r = 0, s;
55
    while ( s = fetch ( n ), s == 0 ) r += ( ( 1 << n ) - 1 ) ;
84
    while (s = fetch(n), s == 0)r += ((1 << n) - 1);
56
    return ( r + s ) ;
85
    return(r + s);
57
}
86
}
58
 
87
 
59
 
88
 
60
/*
89
/*
61
    READ A TDF INTEGER FROM THE INPUT FILE
90
    READ A TDF INTEGER FROM THE INPUT FILE
Line 65... Line 94...
65
    is encoded as a series of 4 bit chunks, the least significant
94
    is encoded as a series of 4 bit chunks, the least significant
66
    three of which represent an octal digit, and the most significant
95
    three of which represent an octal digit, and the most significant
67
    of which is a flag which is set to mark the last digit.
96
    of which is a flag which is set to mark the last digit.
68
*/
97
*/
69
 
98
 
70
long tdf_int
99
long
71
    PROTO_Z ()
100
tdf_int(void)
72
{
101
{
73
    long dig ;
102
    long dig;
74
    long num = 0 ;
103
    long num = 0;
75
    if ( read_error ) return ( 0 ) ;
104
    if (read_error) return(0);
76
    do {
105
    do {
77
	dig = fetch ( 4 ) ;
106
	dig = fetch(4);
78
	num = 8 * num + ( dig & 7 ) ;
107
	num = 8 * num + (dig & 7);
79
    } while ( !( dig & 8 ) ) ;
108
    } while (!(dig & 8));
80
    return ( num ) ;
109
    return(num);
81
}
110
}
82
 
111
 
83
 
112
 
84
/*
113
/*
85
    BUFFER FOR LARGE TDF INTEGERS
114
    BUFFER FOR LARGE TDF INTEGERS
Line 87... Line 116...
87
    Larger TDF integers are stored as strings of octal digits.  This
116
    Larger TDF integers are stored as strings of octal digits.  This
88
    buffer is used to hold them temporarily.  tdf_int_digits gives
117
    buffer is used to hold them temporarily.  tdf_int_digits gives
89
    the number of octal digits read.
118
    the number of octal digits read.
90
*/
119
*/
91
 
120
 
92
int tdf_int_digits ;
121
int tdf_int_digits;
93
static char tdf_int_buff [1000] ;
122
static char tdf_int_buff[1000];
94
 
123
 
95
 
124
 
96
/*
125
/*
97
    READ A TDF INTEGER AS A STRING OF OCTAL DIGITS
126
    READ A TDF INTEGER AS A STRING OF OCTAL DIGITS
98
 
127
 
99
    A TDF integer is read into the buffer tdf_int_buff, with its length being
128
    A TDF integer is read into the buffer tdf_int_buff, with its length being
100
    recorded in tdf_int_digits.
129
    recorded in tdf_int_digits.
101
*/
130
*/
102
 
131
 
103
char *tdf_int_str
132
char *
104
    PROTO_Z ()
133
tdf_int_str(void)
105
{
134
{
106
    long dig ;
135
    long dig;
107
    int i = 0 ;
136
    int i = 0;
108
    int reported = 0 ;
137
    int reported = 0;
109
    if ( read_error ) {
138
    if (read_error) {
110
	/* allow for recovery */
139
	/* allow for recovery */
111
	tdf_int_digits = 1 ;
140
	tdf_int_digits = 1;
112
	return ( "0" ) ;
141
	return("0");
113
    }
142
    }
114
    do {
143
    do {
115
	dig = fetch ( 4 ) ;
144
	dig = fetch(4);
116
	if ( i < 1000 ) {
145
	if (i < 1000) {
117
	    tdf_int_buff [i] = charact ( dig & 7 ) ;
146
	    tdf_int_buff[i] = charact(dig & 7);
118
	    i++ ;
147
	    i++;
119
	} else {
148
	} else {
120
	    if ( !reported ) input_error ( "Numeric overflow" ) ;
149
	    if (!reported)input_error("Numeric overflow");
121
	    reported = 1 ;
150
	    reported = 1;
122
	}
151
	}
123
    } while ( !( dig & 8 ) ) ;
152
    } while (!(dig & 8));
124
    tdf_int_buff [i] = 0 ;
153
    tdf_int_buff[i] = 0;
125
    tdf_int_digits = i ;
154
    tdf_int_digits = i;
126
    return ( tdf_int_buff ) ;
155
    return(tdf_int_buff);
127
}
156
}
128
 
157
 
129
 
158
 
130
/*
159
/*
131
    READ AN 8-BIT STRING
160
    READ AN 8-BIT STRING
Line 133... Line 162...
133
    Only strings consisting of 8-bit characters are actually dealt with
162
    Only strings consisting of 8-bit characters are actually dealt with
134
    at the moment.  This routine decodes such a string of length n,
163
    at the moment.  This routine decodes such a string of length n,
135
    translating any unprintable characters into escape sequences.
164
    translating any unprintable characters into escape sequences.
136
*/
165
*/
137
 
166
 
138
string get_string
167
string
139
    PROTO_N ( ( n, sz ) )
-
 
140
    PROTO_T ( long n X long sz )
168
get_string(long n, long sz)
141
{
169
{
142
    long i ;
170
    long i;
143
    string s ;
171
    string s;
144
    char buff [5000] ;
172
    char buff[5000];
145
    char *p = buff ;
173
    char *p = buff;
146
    for ( i = 0 ; i < n ; i++ ) {
174
    for (i = 0; i < n; i++) {
147
	int c = ( int ) fetch ( ( int ) sz ) ;
175
	int c = (int)fetch((int)sz);
148
	if ( printable ( c ) ) {
176
	if (printable(c)) {
149
	    if ( c == SLASH || c == QUOTE ) *( p++ ) = SLASH ;
177
	    if (c == SLASH || c == QUOTE)*(p++) = SLASH;
150
	    *( p++ ) = ( char ) c ;
178
	    *(p++) = (char)c;
151
	} else {
179
	} else {
152
	    *( p++ ) = SLASH ;
180
	    *(p++) = SLASH;
153
	    if ( c == NEWLINE ) {
181
	    if (c == NEWLINE) {
154
		*( p++ ) = 'n' ;
182
		*(p++) = 'n';
155
	    } else if ( c == TAB ) {
183
	    } else if (c == TAB) {
156
		*( p++ ) = 't' ;
184
		*(p++) = 't';
157
	    } else {
185
	    } else {
158
		*( p++ ) = charact ( c / 64 ) ;
186
		*(p++) = charact(c / 64);
159
		*( p++ ) = charact ( ( c % 64 ) / 8 ) ;
187
		*(p++) = charact((c % 64) / 8);
160
		*( p++ ) = charact ( c % 8 ) ;
188
		*(p++) = charact(c % 8);
161
	    }
189
	    }
162
	}
190
	}
163
    }
191
    }
164
    *( p++ ) = 0 ;
192
    *(p++) = 0;
165
    n = ( int ) ( p - buff ) ;
193
    n = (int)(p - buff);
166
    s = alloc_nof ( char, n ) ;
194
    s = alloc_nof(char, n);
167
    IGNORE memcpy ( s, buff, ( size_t ) n ) ;
195
    IGNORE memcpy(s, buff,(size_t)n);
168
    return ( s ) ;
196
    return(s);
169
}
197
}
170
 
198
 
171
 
199
 
172
/*
200
/*
173
    DECODE A TDF STRING
201
    DECODE A TDF STRING
Line 176... Line 204...
176
    of bits per character and the string length followed by the
204
    of bits per character and the string length followed by the
177
    appropriate number of characters.  If the character size is not 8
205
    appropriate number of characters.  If the character size is not 8
178
    or the string is too long, it is deemed to be unprintable.
206
    or the string is too long, it is deemed to be unprintable.
179
*/
207
*/
180
 
208
 
181
string de_tdfstring
209
string
182
    PROTO_Z ()
210
de_tdfstring(void)
183
{
211
{
184
    string s ;
212
    string s;
185
    long sz = tdf_int () ;
213
    long sz = tdf_int();
186
    long n = tdf_int () ;
214
    long n = tdf_int();
187
    if ( sz == 8 && n < 1000 ) {
215
    if (sz == 8 && n < 1000) {
188
	s = get_string ( n, sz ) ;
216
	s = get_string(n, sz);
189
    } else {
217
    } else {
190
	skip_bits ( ( long ) ( n * sz ) ) ;
218
	skip_bits((long)(n * sz));
191
	s = "<UNPRINTABLE>" ;
219
	s = "<UNPRINTABLE>";
192
    }
220
    }
193
    return ( s ) ;
221
    return(s);
194
}
222
}
195
 
223
 
196
 
224
 
197
/*
225
/*
198
    DECODE AN ALIGNED TDF STRING
226
    DECODE AN ALIGNED TDF STRING
199
 
227
 
200
    This routine is identical to that above except that there are a
228
    This routine is identical to that above except that there are a
201
    couple of alignments.  This is used by de_extern_name.
229
    couple of alignments.  This is used by de_extern_name.
202
*/
230
*/
203
 
231
 
204
string de_tdfstring_align
232
string
205
    PROTO_Z ()
233
de_tdfstring_align(void)
206
{
234
{
207
    string s ;
235
    string s;
208
    long sz = tdf_int () ;
236
    long sz = tdf_int();
209
    long n = tdf_int () ;
237
    long n = tdf_int();
210
    byte_align () ;
238
    byte_align();
211
    if ( sz == 8 && n < 1000 ) {
239
    if (sz == 8 && n < 1000) {
212
	s = get_string ( n, sz ) ;
240
	s = get_string(n, sz);
213
    } else {
241
    } else {
214
	skip_bits ( ( long ) ( n * sz ) ) ;
242
	skip_bits((long)(n * sz));
215
	s = "<UNPRINTABLE>" ;
243
	s = "<UNPRINTABLE>";
216
    }
244
    }
217
    byte_align () ;
245
    byte_align();
218
    return ( s ) ;
246
    return(s);
219
}
247
}
220
 
248
 
221
 
249
 
222
/*
250
/*
223
    DECODE A UNIQUE IDENTIFIER
251
    DECODE A UNIQUE IDENTIFIER
224
 
252
 
225
    A unique consists of an array of strings.  The end of the array is marked
253
    A unique consists of an array of strings.  The end of the array is marked
226
    by a null string.
254
    by a null string.
227
*/
255
*/
228
 
256
 
229
unique de_unique
257
unique
230
    PROTO_Z ()
258
de_unique(void)
231
{
259
{
232
    long i, n ;
260
    long i, n;
233
    unique u ;
261
    unique u;
234
    n = tdf_int () ;
262
    n = tdf_int();
235
    u = alloc_nof ( string, n + 1 ) ;
263
    u = alloc_nof(string, n + 1);
236
    for ( i = 0 ; i < n ; i++ ) u [i] = de_tdfstring_align () ;
264
    for (i = 0; i < n; i++)u[i] = de_tdfstring_align();
237
    u [n] = null ;
265
    u[n] = null;
238
    return ( u ) ;
266
    return(u);
239
}
267
}
240
 
268
 
241
 
269
 
242
/*
270
/*
243
    DECODE AN EXTERNAL NAME
271
    DECODE AN EXTERNAL NAME
244
 
272
 
245
    A number of bits are read and, according to their value, either a
273
    A number of bits are read and, according to their value, either a
246
    string or a unique is decoded.
274
    string or a unique is decoded.
247
*/
275
*/
248
 
276
 
249
external de_extern_name
277
external
250
    PROTO_Z ()
278
de_extern_name(void)
251
{
279
{
252
    external e ;
280
    external e;
253
    long n = de_external () ;
281
    long n = de_external();
254
    byte_align () ;
282
    byte_align();
255
    switch ( n ) {
283
    switch (n) {
256
	case external_string_extern : {
284
	case external_string_extern: {
257
	    e.simple = 1 ;
285
	    e.simple = 1;
258
	    e.val.str = de_tdfstring_align () ;
286
	    e.val.str = de_tdfstring_align();
259
	    break ;
287
	    break;
260
	}
288
	}
261
	case external_unique_extern : {
289
	case external_unique_extern: {
262
	    e.simple = 0 ;
290
	    e.simple = 0;
263
	    e.val.uniq = de_unique () ;
291
	    e.val.uniq = de_unique();
264
	    break ;
292
	    break;
265
	}
293
	}
266
	case external_chain_extern : {
294
	case external_chain_extern: {
267
	    e.simple = 1 ;
295
	    e.simple = 1;
268
	    e.val.str = de_tdfstring_align () ;
296
	    e.val.str = de_tdfstring_align();
269
	    IGNORE tdf_int () ;
297
	    IGNORE tdf_int();
270
	    break ;
298
	    break;
271
	}
299
	}
272
	default : {
300
	default : {
273
	    e.simple = 1 ;
301
	    e.simple = 1;
274
	    e.val.str = "<ERROR>" ;
302
	    e.val.str = "<ERROR>";
275
	    break ;
303
	    break;
276
	}
304
	}
277
    }
305
    }
278
    return ( e ) ;
306
    return(e);
279
}
307
}
280
 
308
 
281
 
309
 
282
/*
310
/*
283
    ARRAY OF FOREIGN SORTS
311
    ARRAY OF FOREIGN SORTS
284
 
312
 
285
    Foreign sorts are identified by means of strings.  This array gives all
313
    Foreign sorts are identified by means of strings.  This array gives all
286
    the foreign sorts known to the program.
314
    the foreign sorts known to the program.
287
*/
315
*/
288
 
316
 
289
int do_foreign_sorts = 0 ;
317
int do_foreign_sorts = 0;
290
long no_foreign_sorts = 0 ;
318
long no_foreign_sorts = 0;
291
sortid *foreign_sorts = null ;
319
sortid *foreign_sorts = null;
292
static long fs_size = 0 ;
320
static long fs_size = 0;
293
 
321
 
294
 
322
 
295
/*
323
/*
296
    ADD A FOREIGN SORT
324
    ADD A FOREIGN SORT
297
 
325
 
298
    The foreign sort with name nm, foreign name fnm and decode letter c is
326
    The foreign sort with name nm, foreign name fnm and decode letter c is
299
    added to the array of foreign sorts.
327
    added to the array of foreign sorts.
300
*/
328
*/
301
 
329
 
302
void add_foreign_sort
330
void
303
    PROTO_N ( ( nm, fnm, c ) )
-
 
304
    PROTO_T ( char *nm X char *fnm X int c )
331
add_foreign_sort(char *nm, char *fnm, int c)
305
{
332
{
306
    long n = no_foreign_sorts++ ;
333
    long n = no_foreign_sorts++;
307
    if ( n >= fs_size ) {
334
    if (n >= fs_size) {
308
	fs_size += 20 ;
335
	fs_size += 20;
309
	foreign_sorts = realloc_nof ( foreign_sorts, sortid, fs_size ) ;
336
	foreign_sorts = realloc_nof(foreign_sorts, sortid, fs_size);
310
    }
337
    }
311
    foreign_sorts [n].name = nm ;
338
    foreign_sorts[n].name = nm;
312
    foreign_sorts [n].fname = fnm ;
339
    foreign_sorts[n].fname = fnm;
313
    foreign_sorts [n].decode = ( char ) c ;
340
    foreign_sorts[n].decode = (char)c;
314
    foreign_sorts [n].res = ( sortname ) ( extra_sorts + n ) ;
341
    foreign_sorts[n].res = (sortname)(extra_sorts + n);
315
    foreign_sorts [n].args = null ;
342
    foreign_sorts[n].args = null;
316
    return ;
343
    return;
317
}
344
}
318
 
345
 
319
 
346
 
320
/*
347
/*
321
    DECODE A COMPLEX SORT AS A STRING
348
    DECODE A COMPLEX SORT AS A STRING
322
*/
349
*/
323
 
350
 
324
static sortid de_complex_sort
351
static
325
    PROTO_N ( ( sn ) )
-
 
326
    PROTO_T ( sortname sn )
352
sortid de_complex_sort(sortname sn)
327
{
353
{
328
    sortid cs ;
354
    sortid cs;
329
    if ( sn == sort_token ) {
355
    if (sn == sort_token) {
330
	long i, n ;
356
	long i, n;
331
	sortid cp, cr ;
357
	sortid cp, cr;
332
	char buff [1000] ;
358
	char buff[1000];
333
	char *p = buff ;
359
	char *p = buff;
334
 
360
 
335
	/* Decode result of token sort */
361
	/* Decode result of token sort */
336
	cr = de_sort_name ( 0 ) ;
362
	cr = de_sort_name(0);
337
	cs.res = cr.res ;
363
	cs.res = cr.res;
338
	cr = de_complex_sort ( cs.res ) ;
364
	cr = de_complex_sort(cs.res);
339
 
365
 
340
	/* Start decoding token sort */
366
	/* Start decoding token sort */
341
	cs.decode = 'T' ;
367
	cs.decode = 'T';
342
	check_list () ;
368
	check_list();
343
	n = tdf_int () ;
369
	n = tdf_int();
344
	cs.args = alloc_nof ( char, n + 1 ) ;
370
	cs.args = alloc_nof(char, n + 1);
345
	IGNORE strcpy ( p, "TOKEN(" ) ;
371
	IGNORE strcpy(p, "TOKEN(");
346
	p = p + strlen ( p ) ;
372
	p = p + strlen(p);
347
 
373
 
348
	/* Decode arguments of token sort */
374
	/* Decode arguments of token sort */
349
	for ( i = 0 ; i < n ; i++ ) {
375
	for (i = 0; i < n; i++) {
350
	    cp = de_sort_name ( 0 ) ;
376
	    cp = de_sort_name(0);
351
	    cp = de_complex_sort ( cp.res ) ;
377
	    cp = de_complex_sort(cp.res);
352
	    if ( i ) *( p++ ) = ',' ;
378
	    if (i)*(p++) = ',';
353
	    IGNORE strcpy ( p, cp.name ) ;
379
	    IGNORE strcpy(p, cp.name);
354
	    p = p + strlen ( p ) ;
380
	    p = p + strlen(p);
355
	    cs.args [i] = cp.decode ;
381
	    cs.args[i] = cp.decode;
356
	}
382
	}
357
	cs.args [n] = 0 ;
383
	cs.args[n] = 0;
358
	IGNORE strcpy ( p, ")->" ) ;
384
	IGNORE strcpy(p, ")->");
359
	p = p + strlen ( p ) ;
385
	p = p + strlen(p);
360
 
386
 
361
	/* Copy token sort */
387
	/* Copy token sort */
362
	IGNORE strcpy ( p, cr.name ) ;
388
	IGNORE strcpy(p, cr.name);
363
	p = alloc_nof ( char, ( int ) strlen ( buff ) + 1 ) ;
389
	p = alloc_nof(char,(int)strlen(buff) + 1);
364
	IGNORE strcpy ( p, buff ) ;
390
	IGNORE strcpy(p, buff);
365
	cs.name = p ;
391
	cs.name = p;
366
    } else {
392
    } else {
367
	/* Non-token sorts are simple */
393
	/* Non-token sorts are simple */
368
	cs = find_sort ( sn ) ;
394
	cs = find_sort(sn);
369
    }
395
    }
370
    return ( cs ) ;
396
    return(cs);
371
}
397
}
372
 
398
 
373
 
399
 
374
/*
400
/*
375
    DECODE A SORTNAME
401
    DECODE A SORTNAME
Line 377... Line 403...
377
    A value representing a sort is read and returned.  If expand is true
403
    A value representing a sort is read and returned.  If expand is true
378
    then the parameters and result of any high-level sort are read but
404
    then the parameters and result of any high-level sort are read but
379
    discarded.
405
    discarded.
380
*/
406
*/
381
 
407
 
382
sortid de_sort_name
408
sortid
383
    PROTO_N ( ( expand ) )
-
 
384
    PROTO_T ( int expand )
409
de_sort_name(int expand)
385
{
410
{
386
    sortname sn = ( sortname ) de_sortname () ;
411
    sortname sn = (sortname)de_sortname();
387
    if ( sn == sort_token && expand ) {
412
    if (sn == sort_token && expand) {
388
	return ( de_complex_sort ( sn ) ) ;
413
	return(de_complex_sort(sn));
389
    }
414
    }
390
    if ( sn == sort_foreign ) {
415
    if (sn == sort_foreign) {
391
	long i ;
416
	long i;
392
	string nm ;
417
	string nm;
393
#if string_ext
418
#if string_ext
394
	long n = fetch_extn ( string_bits ) ;
419
	long n = fetch_extn(string_bits);
395
#else
420
#else
396
	long n = fetch ( string_bits ) ;
421
	long n = fetch(string_bits);
397
#endif
422
#endif
398
	if ( n != string_make_string ) {
423
	if (n != string_make_string) {
399
	    input_error ( "Unknown foreign sort" ) ;
424
	    input_error("Unknown foreign sort");
400
	}
425
	}
401
	nm = de_tdfstring () ;
426
	nm = de_tdfstring();
402
	for ( i = 0 ; i < no_foreign_sorts ; i++ ) {
427
	for (i = 0; i < no_foreign_sorts; i++) {
403
	    if ( streq ( nm, foreign_sorts [i].fname ) ) {
428
	    if (streq(nm, foreign_sorts[i].fname)) {
404
		return ( foreign_sorts [i] ) ;
429
		return(foreign_sorts[i]);
405
	    }
430
	    }
406
	}
431
	}
407
	add_foreign_sort ( nm, nm, 'F' ) ;
432
	add_foreign_sort(nm, nm, 'F');
408
	return ( foreign_sorts [i] ) ;
433
	return(foreign_sorts[i]);
409
    }
434
    }
410
    return ( find_sort ( sn ) ) ;
435
    return(find_sort(sn));
411
}
436
}