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 32... Line 62...
32 
#include "calculus.h"
 62 
#include "calculus.h"
33 
#include "error.h"
 63 
#include "error.h"
34 
#include "common.h"
 64 
#include "common.h"
35 
#include "type_ops.h"
 65 
#include "type_ops.h"
36 
#include "xalloc.h"
 66 
#include "xalloc.h"
37 
 
 67 
 
38 
 
 68 
 
39 
/*
 69 
/*
40 
    TYPE REPRESENTING A LIST OF ALGEBRAS
 70 
 * TYPE REPRESENTING A LIST OF ALGEBRAS
41 
 
 71 
 *
42 
    This type is used to represent the list of all algebras.
 72 
 * This type is used to represent the list of all algebras.
43 
*/
 73 
 */
44 
 
 74 
 
45 
typedef struct ALGEBRA_LIST_tag {
 75 
typedef struct ALGEBRA_LIST_tag {
46 
    ALGEBRA_DEFN alg ;
 76 
    ALGEBRA_DEFN alg;
47 
    struct ALGEBRA_LIST_tag *next ;
 77 
    struct ALGEBRA_LIST_tag *next;
48 
} ALGEBRA_LIST ;
 78 
} ALGEBRA_LIST;
49 
 
 79 
 
50 
 
 80 
 
51 
/*
 81 
/*
52 
    CURRENT ALGEBRA
 82 
 * CURRENT ALGEBRA
53 
 
 83 
 *
54 
    The variable algebra holds all the information on the algebra read
 84 
 * The variable algebra holds all the information on the algebra read
55 
    from the input file.  The list all_algebras contains a list of all
 85 
 * from the input file.  The list all_algebras contains a list of all
56 
    the algebras defined.
 86 
 * the algebras defined.
57 
*/
 87 
 */
58 
 
 88 
 
59 
ALGEBRA_DEFN *algebra = NULL ;
 89 
ALGEBRA_DEFN *algebra = NULL;
60 
static ALGEBRA_LIST *all_algebras = NULL ;
 90 
static ALGEBRA_LIST *all_algebras = NULL;
61 
 
 91 
 
62 
 
 92 
 
63 
/*
 93 
/*
64 
    CREATE A NEW ALGEBRA
 94 
 * CREATE A NEW ALGEBRA
65 
 
 95 
 *
66 
    This routine allocates and initialises a new algebra structure.
 96 
 * This routine allocates and initialises a new algebra structure.
67 
*/
 97 
 */
68 
 
 98 
 
69 
void new_algebra
 99 
void
70 
    PROTO_Z ()
 100 
new_algebra(void)
71 
{
 101 
{
72 
    ALGEBRA_LIST *p = xmalloc_nof ( ALGEBRA_LIST, 1 ) ;
 102 
    ALGEBRA_LIST *p = xmalloc_nof(ALGEBRA_LIST, 1);
73 
    p->alg.name = "ALGEBRA" ;
 103 
    p->alg.name = "ALGEBRA";
74 
    p->alg.major_no = 1 ;
 104 
    p->alg.major_no = 1;
75 
    p->alg.minor_no = 0 ;
 105 
    p->alg.minor_no = 0;
76 
    p->alg.primitives = NULL_list ( PRIMITIVE_P ) ;
 106 
    p->alg.primitives = NULL_list(PRIMITIVE_P);
77 
    p->alg.identities = NULL_list ( IDENTITY_P ) ;
 107 
    p->alg.identities = NULL_list(IDENTITY_P);
78 
    p->alg.enumerations = NULL_list ( ENUM_P ) ;
 108 
    p->alg.enumerations = NULL_list(ENUM_P);
79 
    p->alg.structures = NULL_list ( STRUCTURE_P ) ;
 109 
    p->alg.structures = NULL_list(STRUCTURE_P);
80 
    p->alg.unions = NULL_list ( UNION_P ) ;
 110 
    p->alg.unions = NULL_list(UNION_P);
81 
    p->alg.types = NULL_list ( TYPE_P ) ;
 111 
    p->alg.types = NULL_list(TYPE_P);
82 
    p->next = all_algebras ;
 112 
    p->next = all_algebras;
83 
    all_algebras = p ;
 113 
    all_algebras = p;
84 
    algebra = &( p->alg ) ;
 114 
    algebra = &(p->alg);
85 
    return ;
 115 
    return;
86 
}
 116 
}
87 
 
 117 
 
88 
 
 118 
 
89 
/*
 119 
/*
90 
    LOOK UP AN ALGEBRA
 120 
 * LOOK UP AN ALGEBRA
91 
 
 121 
 *
92 
    This routine looks up the algebra named nm.  It returns null if the
 122 
 * This routine looks up the algebra named nm.  It returns null if the
93 
    algebra has not been defined.
 123 
 * algebra has not been defined.
94 
*/
 124 
 */
95 
 
 125 
 
96 
ALGEBRA_DEFN *find_algebra
 126 
ALGEBRA_DEFN *
- 
 
 127 
find_algebra(char *nm)
- 
 
 128 
{
97 
    PROTO_N ( ( nm ) )
 129 
    ALGEBRA_LIST *p;
- 
 
 130 
    for (p = all_algebras; p != NULL; p = p->next) {
- 
 
 131 
	if (streq(p->alg.name, nm)) {
- 
 
 132 
		return(&(p->alg));
- 
 
 133 
	}
- 
 
 134 
    }
- 
 
 135 
    return(NULL);
- 
 
 136 
}
- 
 
 137 
 
- 
 
 138 
 
- 
 
 139 
/*
- 
 
 140 
 * LAST IDENTIFIER
- 
 
 141 
 *
- 
 
 142 
 * This variable is set by name_type and name_aux_type to the identifier
- 
 
 143 
 * of the last non-composite type looked up.
- 
 
 144 
 */
- 
 
 145 
 
- 
 
 146 
static CLASS_ID_P last_id = NULL_ptr(CLASS_ID);
- 
 
 147 
 
- 
 
 148 
 
- 
 
 149 
/*
- 
 
 150 
 * REGISTER A TYPE
- 
 
 151 
 *
- 
 
 152 
 * This routine adds the type t to the list of all types.
- 
 
 153 
 */
- 
 
 154 
 
- 
 
 155 
TYPE_P
- 
 
 156 
register_type(TYPE_P t)
- 
 
 157 
{
- 
 
 158 
    char *nm = name_type(t);
- 
 
 159 
    CLASS_ID_P id = last_id;
- 
 
 160 
    LIST(TYPE_P)r = algebra->types;
- 
 
 161 
    while (!IS_NULL_list(r)) {
- 
 
 162 
	TYPE_P s = DEREF_ptr(HEAD_list(r));
- 
 
 163 
	if (streq(name_type(s), nm)) {
- 
 
 164 
 
- 
 
 165 
	    /* Check for multiple definition */
- 
 
 166 
	    if (!IS_type_undef(DEREF_type(s))) {
- 
 
 167 
		char *fn1 = DEREF_string(cid_file(id));
- 
 
 168 
		int ln1 = DEREF_int(cid_line(id));
- 
 
 169 
		char *fn2 = DEREF_string(cid_file(last_id));
- 
 
 170 
		int ln2 = DEREF_int(cid_line(last_id));
- 
 
 171 
		if (fn2 == crt_file_name) {
98 
    PROTO_T ( char *nm )
 172 
		    char *fn = fn1;
- 
 
 173 
		    int ln = ln1;
- 
 
 174 
		    fn1 = fn2;
- 
 
 175 
		    ln1 = ln2;
- 
 
 176 
		    fn2 = fn;
- 
 
 177 
		    ln2 = ln;
- 
 
 178 
		}
- 
 
 179 
		error_posn(ERROR_SERIOUS, fn1, ln1,
- 
 
 180 
			   "Type %s already defined (at %s, line %d)", nm, fn2,
- 
 
 181 
			   ln2);
- 
 
 182 
	    }
- 
 
 183 
 
- 
 
 184 
	    COPY_type(s, DEREF_type(t));
- 
 
 185 
	    return(s);
- 
 
 186 
	}
- 
 
 187 
	r = TAIL_list(r);
- 
 
 188 
    }
- 
 
 189 
    CONS_ptr(t, algebra->types, algebra->types);
- 
 
 190 
    return(t);
- 
 
 191 
}
- 
 
 192 
 
- 
 
 193 
 
- 
 
 194 
/*
- 
 
 195 
 * LOOK UP A NAMED TYPE
- 
 
 196 
 *
- 
 
 197 
 * This routine looks up the type named nm in the list of all types
- 
 
 198 
 * associated with the algebra alg.  The type is created if necessary,
- 
 
 199 
 * and the result is returned.
- 
 
 200 
 */
- 
 
 201 
 
- 
 
 202 
TYPE_P
- 
 
 203 
find_type(ALGEBRA_DEFN *alg, char *nm)
99 
{
 204 
{
- 
 
 205 
    TYPE s0;
100 
    ALGEBRA_LIST *p ;
 206 
    TYPE_P s;
- 
 
 207 
    LIST(TYPE_P)t = alg->types;
101 
    for ( p = all_algebras ; p != NULL ; p = p->next ) {
 208 
    while (!IS_NULL_list(t)) {
- 
 
 209 
	s = DEREF_ptr(HEAD_list(t));
102 
	if ( streq ( p->alg.name, nm ) ) return ( &( p->alg ) ) ;
 210 
	if (streq(name_type(s), nm)) {
- 
 
 211 
		return(s);
- 
 
 212 
	}
- 
 
 213 
	t = TAIL_list(t);
103 
    }
 214 
    }
- 
 
 215 
    s = MAKE_ptr(SIZE_type);
- 
 
 216 
    MAKE_type_undef(0, nm, s0);
- 
 
 217 
    COPY_type(s, s0);
- 
 
 218 
    s = register_type(s);
104 
    return ( NULL ) ;
 219 
    return(s);
105 
}
 220 
}
106 
 
 221 
 
107 
 
 222 
 
108 
/*
 223 
/*
109 
    LAST IDENTIFIER
 224 
 * DOES A TYPE INVOLVE AN IDENTITY
- 
 
 225 
 *
- 
 
 226 
 * This routine checks whether the type t is an identity or a compound
- 
 
 227 
 * type derived from an identity.
- 
 
 228 
 */
110 
 
 229 
 
111 
    This variable is set by name_type and name_aux_type to the identifier
 - 
 
112 
    of the last non-composite type looked up.
 - 
 
113 
*/
 230 
int
114 
 
 - 
 
115 
static CLASS_ID_P last_id = NULL_ptr ( CLASS_ID ) ;
 - 
 
116 
 
 - 
 
117 
 
 - 
 
118 
/*
 - 
 
119 
    REGISTER A TYPE
 - 
 
120 
 
 - 
 
121 
    This routine adds the type t to the list of all types.
 - 
 
122 
*/
 - 
 
123 
 
 - 
 
124 
TYPE_P register_type
 - 
 
125 
    PROTO_N ( ( t ) )
 - 
 
126 
    PROTO_T ( TYPE_P t )
 231 
is_identity_type(TYPE_P t)
127 
{
 232 
{
128 
    char *nm = name_type ( t ) ;
 - 
 
129 
    CLASS_ID_P id = last_id ;
 - 
 
130 
    LIST ( TYPE_P ) r = algebra->types ;
 - 
 
131 
    while ( !IS_NULL_list ( r ) ) {
 - 
 
132 
	TYPE_P s = DEREF_ptr ( HEAD_list ( r ) ) ;
 - 
 
133 
	if ( streq ( name_type ( s ), nm ) ) {
 - 
 
134 
 
 - 
 
135 
	    /* Check for multiple definition */
 - 
 
136 
	    if ( !IS_type_undef ( DEREF_type ( s ) ) ) {
 - 
 
137 
		char *fn1 = DEREF_string ( cid_file ( id ) ) ;
 - 
 
138 
		int ln1 = DEREF_int ( cid_line ( id ) ) ;
 - 
 
139 
		char *fn2 = DEREF_string ( cid_file ( last_id ) ) ;
 - 
 
140 
		int ln2 = DEREF_int ( cid_line ( last_id ) ) ;
 - 
 
141 
		if ( fn2 == crt_file_name ) {
 - 
 
142 
		    char *fn = fn1 ;
 - 
 
143 
		    int ln = ln1 ;
 - 
 
144 
		    fn1 = fn2 ;
 - 
 
145 
		    ln1 = ln2 ;
 - 
 
146 
		    fn2 = fn ;
 - 
 
147 
		    ln2 = ln ;
 - 
 
148 
		}
 - 
 
149 
		error_posn ( ERROR_SERIOUS, fn1, ln1,
 - 
 
150 
			     "Type %s already defined (at %s, line %d)",
 - 
 
151 
			     nm, fn2, ln2 ) ;
 - 
 
152 
	    }
 - 
 
153 
 
 - 
 
154 
	    COPY_type ( s, DEREF_type ( t ) ) ;
 - 
 
155 
	    return ( s ) ;
 - 
 
156 
	}
 - 
 
157 
	r = TAIL_list ( r ) ;
 - 
 
158 
    }
 - 
 
159 
    CONS_ptr ( t, algebra->types, algebra->types ) ;
 - 
 
160 
    return ( t ) ;
 - 
 
161 
}
 - 
 
162 
 
 - 
 
163 
 
 - 
 
164 
/*
 - 
 
165 
    LOOK UP A NAMED TYPE
 - 
 
166 
 
 - 
 
167 
    This routine looks up the type named nm in the list of all types
 - 
 
168 
    associated with the algebra alg.  The type is created if necessary,
 - 
 
169 
    and the result is returned.
 - 
 
170 
*/
 - 
 
171 
 
 - 
 
172 
TYPE_P find_type
 - 
 
173 
    PROTO_N ( ( alg, nm ) )
 - 
 
174 
    PROTO_T ( ALGEBRA_DEFN *alg X char *nm )
 - 
 
175 
{
 - 
 
176 
    TYPE s0 ;
 - 
 
177 
    TYPE_P s ;
 - 
 
178 
    LIST ( TYPE_P ) t = alg->types ;
 - 
 
179 
    while ( !IS_NULL_list ( t ) ) {
 - 
 
180 
	s = DEREF_ptr ( HEAD_list ( t ) ) ;
 - 
 
181 
	if ( streq ( name_type ( s ), nm ) ) return ( s ) ;
 - 
 
182 
	t = TAIL_list ( t ) ;
 - 
 
183 
    }
 - 
 
184 
    s = MAKE_ptr ( SIZE_type ) ;
 - 
 
185 
    MAKE_type_undef ( 0, nm, s0 ) ;
 - 
 
186 
    COPY_type ( s, s0 ) ;
 - 
 
187 
    s = register_type ( s ) ;
 - 
 
188 
    return ( s ) ;
 - 
 
189 
}
 - 
 
190 
 
 - 
 
191 
 
 - 
 
192 
/*
 - 
 
193 
    DOES A TYPE INVOLVE AN IDENTITY
 - 
 
194 
 
 - 
 
195 
    This routine checks whether the type t is an identity or a compound
 - 
 
196 
    type derived from an identity.
 - 
 
197 
*/
 - 
 
198 
 
 - 
 
199 
int is_identity_type
 - 
 
200 
    PROTO_N ( ( t ) )
 - 
 
201 
    PROTO_T ( TYPE_P t )
 - 
 
202 
{
 - 
 
203 
    TYPE t0 = DEREF_type ( t ) ;
 233 
    TYPE t0 = DEREF_type(t);
204 
    while ( IS_type_ptr_etc ( t0 ) ) {
 234 
    while (IS_type_ptr_etc(t0)) {
205 
	t0 = DEREF_type ( DEREF_ptr ( type_ptr_etc_sub ( t0 ) ) ) ;
 235 
	t0 = DEREF_type(DEREF_ptr(type_ptr_etc_sub(t0)));
206 
    }
 236 
    }
207 
    return ( IS_type_ident ( t0 ) ) ;
 237 
    return(IS_type_ident(t0));
208 
}
 238 
}
209 
 
 239 
 
210 
 
 240 
 
211 
/*
 241 
/*
212 
    DEAL WITH COMPOUND TYPES INVOLVING IDENTITIES
 242 
 * DEAL WITH COMPOUND TYPES INVOLVING IDENTITIES
213 
 
 243 
 *
214 
    From the point of view of the list of all types, identity types are
 244 
 * From the point of view of the list of all types, identity types are
215 
    distinct from their definitions.  This routine is called after creating
 245 
 * distinct from their definitions.  This routine is called after creating
216 
    a compound type, r, to ensure that the corresponding type with any
 246 
 * a compound type, r, to ensure that the corresponding type with any
217 
    identities replaced by their definition is also created.
 247 
 * identities replaced by their definition is also created.
218 
*/
 248 
 */
219 
 
 249 
 
220 
static TYPE_P compound_identity
 250 
static TYPE_P
221 
    PROTO_N ( ( r, depth ) )
 - 
 
222 
    PROTO_T ( TYPE_P r X int depth )
 251 
compound_identity(TYPE_P r, int depth)
223 
{
 252 
{
224 
    TYPE r0 = DEREF_type ( r ) ;
 253 
    TYPE r0 = DEREF_type(r);
225 
    if ( depth > MAX_TYPE_DEPTH ) {
 254 
    if (depth > MAX_TYPE_DEPTH) {
226 
	error ( ERROR_SERIOUS, "Cyclic type definition involving %s",
 255 
	error(ERROR_SERIOUS, "Cyclic type definition involving %s",
227 
		name_type ( r ) ) ;
 256 
		name_type(r));
228 
	return ( NULL_ptr ( TYPE ) ) ;
 257 
	return(NULL_ptr(TYPE));
- 
 
 258 
    }
- 
 
 259 
    if (IS_type_ident(r0)) {
- 
 
 260 
	IDENTITY_P a = DEREF_ptr(type_ident_id(DEREF_type(r)));
- 
 
 261 
	TYPE_P s = DEREF_ptr(ident_defn(a));
- 
 
 262 
	return(s);
229 
    }
 263 
    }
230 
    if ( IS_type_ident ( r0 ) ) {
 - 
 
231 
	IDENTITY_P a = DEREF_ptr ( type_ident_id ( DEREF_type ( r ) ) ) ;
 - 
 
232 
	TYPE_P s = DEREF_ptr ( ident_defn ( a ) ) ;
 - 
 
233 
	return ( s ) ;
 - 
 
234 
    }
 - 
 
235 
    if ( IS_type_ptr_etc ( r0 ) ) {
 264 
    if (IS_type_ptr_etc(r0)) {
236 
	unsigned tag = TAG_type ( r0 ) ;
 265 
	unsigned tag = TAG_type(r0);
237 
	TYPE_P s = DEREF_ptr ( type_ptr_etc_sub ( r0 ) ) ;
 266 
	TYPE_P s = DEREF_ptr(type_ptr_etc_sub(r0));
238 
	s = compound_identity ( s, depth ) ;
 267 
	s = compound_identity(s, depth);
239 
	if ( !IS_NULL_ptr ( s ) ) {
 268 
	if (!IS_NULL_ptr(s)) {
240 
	    return ( compound_type ( tag, s, depth + 1 ) ) ;
 269 
	    return(compound_type(tag, s, depth + 1));
241 
	}
 270 
	}
242 
    }
 271 
    }
243 
    return ( NULL_ptr ( TYPE ) ) ;
 272 
    return(NULL_ptr(TYPE));
244 
}
 273 
}
245 
 
 274 
 
246 
 
 275 
 
247 
/*
 276 
/*
248 
    CREATE A COMPOUND TYPE
 277 
 * CREATE A COMPOUND TYPE
249 
 
 278 
 *
250 
    This routine creates a compound type from the type operation indicated
 279 
 * This routine creates a compound type from the type operation indicated
251 
    by tag and the sub-type r.  The routine is designed to ensure that
 280 
 * by tag and the sub-type r.  The routine is designed to ensure that
252 
    only one copy of each type is created.
 281 
 * only one copy of each type is created.
253 
*/
 282 
 */
254 
 
 283 
 
255 
TYPE_P compound_type
 284 
TYPE_P
256 
    PROTO_N ( ( tag, r, depth ) )
 - 
 
257 
    PROTO_T ( unsigned tag X TYPE_P r X int depth )
 285 
compound_type(unsigned tag, TYPE_P r, int depth)
258 
{
 286 
{
259 
    TYPE s0 ;
 287 
    TYPE s0;
260 
    TYPE_P s ;
 288 
    TYPE_P s;
261 
    LIST ( TYPE_P ) t = algebra->types ;
 289 
    LIST(TYPE_P)t = algebra->types;
262 
 
 290 
 
263 
    /* Search for uses */
 291 
    /* Search for uses */
264 
    while ( !IS_NULL_list ( t ) ) {
 292 
    while (!IS_NULL_list(t)) {
265 
	s = DEREF_ptr ( HEAD_list ( t ) ) ;
 293 
	s = DEREF_ptr(HEAD_list(t));
266 
	s0 = DEREF_type ( s ) ;
 294 
	s0 = DEREF_type(s);
267 
	if ( TAG_type ( s0 ) == tag ) {
 295 
	if (TAG_type(s0) == tag) {
268 
	    TYPE_P rr = DEREF_ptr ( type_ptr_etc_sub ( s0 ) ) ;
 296 
	    TYPE_P rr = DEREF_ptr(type_ptr_etc_sub(s0));
269 
	    if ( EQ_ptr ( r, rr ) ) return ( s ) ;
 297 
	    if (EQ_ptr(r, rr)) return(s);
270 
	}
 298 
	}
271 
	t = TAIL_list ( t ) ;
 299 
	t = TAIL_list(t);
272 
    }
 300 
    }
273 
    s = MAKE_ptr ( SIZE_type ) ;
 301 
    s = MAKE_ptr(SIZE_type);
274 
    MAKE_type_ptr_etc ( tag, 0, r, s0 ) ;
 302 
    MAKE_type_ptr_etc(tag, 0, r, s0);
275 
    COPY_type ( s, s0 ) ;
 303 
    COPY_type(s, s0);
276 
    CONS_ptr ( s, algebra->types, algebra->types ) ;
 304 
    CONS_ptr(s, algebra->types, algebra->types);
277 
    ( void ) compound_identity ( s, depth ) ;
 305 
    (void)compound_identity(s, depth);
278 
    return ( s ) ;
 306 
    return(s);
279 
}
 307 
}
280 
 
 308 
 
281 
 
 309 
 
282 
/*
 310 
/*
283 
    CHECK FOR UNDEFINED TYPES
 311 
 * CHECK FOR UNDEFINED TYPES
- 
 
 312 
 *
- 
 
 313 
 * This routine scans the list of all types for any which remain undefined
- 
 
 314 
 * at the end of the compilation.  It also calculates the sizes of all
- 
 
 315 
 * the defined types.
- 
 
 316 
 */
284 
 
 317 
 
285 
    This routine scans the list of all types for any which remain undefined
 - 
 
286 
    at the end of the compilation.  It also calculates the sizes of all
 - 
 
287 
    the defined types.
 - 
 
288 
*/
 318 
void
289 
 
 - 
 
290 
void check_types
 319 
check_types(void)
291 
    PROTO_Z ()
 - 
 
292 
{
 320 
{
293 
    LIST ( TYPE_P ) t = algebra->types ;
 321 
    LIST(TYPE_P)t = algebra->types;
294 
    while ( !IS_NULL_list ( t ) ) {
 322 
    while (!IS_NULL_list(t)) {
295 
	TYPE_P s = DEREF_ptr ( HEAD_list ( t ) ) ;
 323 
	TYPE_P s = DEREF_ptr(HEAD_list(t));
296 
	TYPE s0 = DEREF_type ( s ) ;
 324 
	TYPE s0 = DEREF_type(s);
297 
	if ( IS_type_undef ( s0 ) ) {
 325 
	if (IS_type_undef(s0)) {
298 
	    char *nm = name_type ( s ) ;
 326 
	    char *nm = name_type(s);
299 
	    error ( ERROR_SERIOUS, "Type %s used but not defined", nm ) ;
 327 
	    error(ERROR_SERIOUS, "Type %s used but not defined", nm);
300 
	} else {
 328 
	} else {
301 
	    int sz = size_type ( s, 0 ) ;
 329 
	    int sz = size_type(s, 0);
302 
	    COPY_int ( type_size ( s0 ), sz ) ;
 330 
	    COPY_int(type_size(s0), sz);
- 
 
 331 
	}
- 
 
 332 
	t = TAIL_list(t);
- 
 
 333 
    }
- 
 
 334 
    return;
- 
 
 335 
}
- 
 
 336 
 
- 
 
 337 
 
- 
 
 338 
/*
- 
 
 339 
 * FIND LIST OF DERIVED TYPES
- 
 
 340 
 *
- 
 
 341 
 * This routine builds up a list of all the types used in the derivation
- 
 
 342 
 * of t.
- 
 
 343 
 */
- 
 
 344 
 
- 
 
 345 
static LIST(TYPE_P)
- 
 
 346 
derived_types(TYPE_P t, LIST(TYPE_P)p)
- 
 
 347 
{
- 
 
 348 
    TYPE t0;
- 
 
 349 
    unsigned tag;
- 
 
 350 
    LIST(TYPE_P)q = p;
- 
 
 351 
    while (!IS_NULL_list(q)) {
- 
 
 352 
	TYPE_P s = DEREF_ptr(HEAD_list(q));
- 
 
 353 
	if (EQ_ptr(s, t)) {
- 
 
 354 
		return(p);
- 
 
 355 
	}
- 
 
 356 
	q = TAIL_list(q);
- 
 
 357 
    }
- 
 
 358 
    CONS_ptr(t, p, p);
- 
 
 359 
    t0 = DEREF_type(t);
- 
 
 360 
    tag = TAG_type(t0);
- 
 
 361 
    switch (tag) {
- 
 
 362 
 
- 
 
 363 
	case type_ident_tag: {
- 
 
 364 
	    /* Identity definition */
- 
 
 365 
	    IDENTITY_P r = DEREF_ptr(type_ident_id(t0));
- 
 
 366 
	    TYPE_P s = DEREF_ptr(ident_defn(r));
- 
 
 367 
	    p = derived_types(s, p);
- 
 
 368 
	    break;
- 
 
 369 
	}
- 
 
 370 
 
- 
 
 371 
	case type_structure_tag: {
- 
 
 372 
	    /* Structure components */
- 
 
 373 
	    STRUCTURE_P r = DEREF_ptr(type_structure_struc(t0));
- 
 
 374 
	    LIST(COMPONENT_P)c = DEREF_list(str_defn(r));
- 
 
 375 
	    while (!IS_NULL_list(c)) {
- 
 
 376 
		COMPONENT_P cmp = DEREF_ptr(HEAD_list(c));
- 
 
 377 
		TYPE_P s = DEREF_ptr(cmp_type(cmp));
- 
 
 378 
		p = derived_types(s, p);
- 
 
 379 
		c = TAIL_list(c);
- 
 
 380 
	    }
- 
 
 381 
	    break;
- 
 
 382 
	}
- 
 
 383 
 
- 
 
 384 
	case type_onion_tag: {
- 
 
 385 
	    /* Union components, fields and maps */
- 
 
 386 
	    UNION_P r = DEREF_ptr(type_onion_un(t0));
- 
 
 387 
	    LIST(COMPONENT_P)c = DEREF_list(un_s_defn(r));
- 
 
 388 
	    LIST(FIELD_P)f = DEREF_list(un_u_defn(r));
- 
 
 389 
	    LIST(MAP_P)m = DEREF_list(un_map(r));
- 
 
 390 
	    while (!IS_NULL_list(c)) {
- 
 
 391 
		COMPONENT_P cmp = DEREF_ptr(HEAD_list(c));
- 
 
 392 
		TYPE_P s = DEREF_ptr(cmp_type(cmp));
- 
 
 393 
		p = derived_types(s, p);
- 
 
 394 
		c = TAIL_list(c);
- 
 
 395 
	    }
- 
 
 396 
	    while (!IS_NULL_list(f)) {
- 
 
 397 
		FIELD_P fld = DEREF_ptr(HEAD_list(f));
- 
 
 398 
		c = DEREF_list(fld_defn(fld));
- 
 
 399 
		while (!IS_NULL_list(c)) {
- 
 
 400 
		    COMPONENT_P cmp = DEREF_ptr(HEAD_list(c));
- 
 
 401 
		    TYPE_P s = DEREF_ptr(cmp_type(cmp));
- 
 
 402 
		    p = derived_types(s, p);
- 
 
 403 
		    c = TAIL_list(c);
- 
 
 404 
		}
- 
 
 405 
		f = TAIL_list(f);
- 
 
 406 
	    }
- 
 
 407 
	    while (!IS_NULL_list(m)) {
- 
 
 408 
		MAP_P map = DEREF_ptr(HEAD_list(m));
- 
 
 409 
		LIST(ARGUMENT_P)a = DEREF_list(map_args(map));
- 
 
 410 
		TYPE_P s = DEREF_ptr(map_ret_type(map));
- 
 
 411 
		p = derived_types(s, p);
- 
 
 412 
		while (!IS_NULL_list(a)) {
- 
 
 413 
		    ARGUMENT_P arg = DEREF_ptr(HEAD_list(a));
- 
 
 414 
		    s = DEREF_ptr(arg_type(arg));
- 
 
 415 
		    p = derived_types(s, p);
- 
 
 416 
		    a = TAIL_list(a);
- 
 
 417 
		}
- 
 
 418 
		m = TAIL_list(m);
- 
 
 419 
	    }
- 
 
 420 
	    break;
- 
 
 421 
	}
- 
 
 422 
 
- 
 
 423 
	case type_list_tag:
- 
 
 424 
	case type_ptr_tag:
- 
 
 425 
	case type_stack_tag:
- 
 
 426 
	case type_vec_tag:
- 
 
 427 
	case type_vec_ptr_tag: {
- 
 
 428 
	    /* Pointer subtypes */
- 
 
 429 
	    TYPE_P s = DEREF_ptr(type_ptr_etc_sub(t0));
- 
 
 430 
	    p = derived_types(s, p);
- 
 
 431 
	    break;
303 
	}
 432 
	}
304 
	t = TAIL_list ( t ) ;
 - 
 
305 
    }
 433 
    }
306 
    return ;
 434 
    return(p);
307 
}
 435 
}
308 
 
 436 
 
309 
 
 437 
 
310 
/*
 438 
/*
311 
    FIND LIST OF DERIVED TYPES
 439 
 * IMPORT A LIST OF TYPES
- 
 
 440 
 *
- 
 
 441 
 * This routine imports all the types in the list t.
- 
 
 442 
 */
312 
 
 443 
 
313 
    This routine builds up a list of all the types used in the derivation
 - 
 
314 
    of t.
 444 
static void
315 
*/
 - 
 
316 
 
 - 
 
317 
static LIST ( TYPE_P ) derived_types
 - 
 
318 
    PROTO_N ( ( t, p ) )
 - 
 
319 
    PROTO_T ( TYPE_P t X LIST ( TYPE_P ) p )
 445 
import_type_list(LIST(TYPE_P)t)
320 
{
 446 
{
321 
    TYPE t0 ;
 - 
 
322 
    unsigned tag ;
 - 
 
323 
    LIST ( TYPE_P ) q = p ;
 - 
 
324 
    while ( !IS_NULL_list ( q ) ) {
 - 
 
325 
	TYPE_P s = DEREF_ptr ( HEAD_list ( q ) ) ;
 - 
 
326 
	if ( EQ_ptr ( s, t ) ) return ( p ) ;
 - 
 
327 
	q = TAIL_list ( q ) ;
 - 
 
328 
    }
 - 
 
329 
    CONS_ptr ( t, p, p ) ;
 - 
 
330 
    t0 = DEREF_type ( t ) ;
 - 
 
331 
    tag = TAG_type ( t0 ) ;
 - 
 
332 
    switch ( tag ) {
 - 
 
333 
 
 - 
 
334 
	case type_ident_tag : {
 - 
 
335 
	    /* Identity definition */
 - 
 
336 
	    IDENTITY_P r = DEREF_ptr ( type_ident_id ( t0 ) ) ;
 - 
 
337 
	    TYPE_P s = DEREF_ptr ( ident_defn ( r ) ) ;
 - 
 
338 
	    p = derived_types ( s, p ) ;
 - 
 
339 
	    break ;
 - 
 
340 
	}
 - 
 
341 
 
 - 
 
342 
	case type_structure_tag : {
 - 
 
343 
	    /* Structure components */
 - 
 
344 
	    STRUCTURE_P r = DEREF_ptr ( type_structure_struc ( t0 ) ) ;
 - 
 
345 
	    LIST ( COMPONENT_P ) c = DEREF_list ( str_defn ( r ) ) ;
 - 
 
346 
	    while ( !IS_NULL_list ( c ) ) {
 - 
 
347 
		COMPONENT_P cmp = DEREF_ptr ( HEAD_list ( c ) ) ;
 - 
 
348 
		TYPE_P s = DEREF_ptr ( cmp_type ( cmp ) ) ;
 - 
 
349 
		p = derived_types ( s, p ) ;
 - 
 
350 
		c = TAIL_list ( c ) ;
 - 
 
351 
	    }
 - 
 
352 
	    break ;
 - 
 
353 
	}
 - 
 
354 
 
 - 
 
355 
	case type_onion_tag : {
 - 
 
356 
	    /* Union components, fields and maps */
 - 
 
357 
	    UNION_P r = DEREF_ptr ( type_onion_un ( t0 ) ) ;
 - 
 
358 
	    LIST ( COMPONENT_P ) c = DEREF_list ( un_s_defn ( r ) ) ;
 - 
 
359 
	    LIST ( FIELD_P ) f = DEREF_list ( un_u_defn ( r ) ) ;
 - 
 
360 
	    LIST ( MAP_P ) m = DEREF_list ( un_map ( r ) ) ;
 - 
 
361 
	    while ( !IS_NULL_list ( c ) ) {
 - 
 
362 
		COMPONENT_P cmp = DEREF_ptr ( HEAD_list ( c ) ) ;
 - 
 
363 
		TYPE_P s = DEREF_ptr ( cmp_type ( cmp ) ) ;
 - 
 
364 
		p = derived_types ( s, p ) ;
 - 
 
365 
		c = TAIL_list ( c ) ;
 - 
 
366 
	    }
 - 
 
367 
	    while ( !IS_NULL_list ( f ) ) {
 - 
 
368 
		FIELD_P fld = DEREF_ptr ( HEAD_list ( f ) ) ;
 - 
 
369 
		c = DEREF_list ( fld_defn ( fld ) ) ;
 - 
 
370 
		while ( !IS_NULL_list ( c ) ) {
 - 
 
371 
		    COMPONENT_P cmp = DEREF_ptr ( HEAD_list ( c ) ) ;
 - 
 
372 
		    TYPE_P s = DEREF_ptr ( cmp_type ( cmp ) ) ;
 - 
 
373 
		    p = derived_types ( s, p ) ;
 - 
 
374 
		    c = TAIL_list ( c ) ;
 - 
 
375 
		}
 - 
 
376 
		f = TAIL_list ( f ) ;
 - 
 
377 
	    }
 - 
 
378 
	    while ( !IS_NULL_list ( m ) ) {
 - 
 
379 
		MAP_P map = DEREF_ptr ( HEAD_list ( m ) ) ;
 - 
 
380 
		LIST ( ARGUMENT_P ) a = DEREF_list ( map_args ( map ) ) ;
 - 
 
381 
		TYPE_P s = DEREF_ptr ( map_ret_type ( map ) ) ;
 - 
 
382 
		p = derived_types ( s, p ) ;
 - 
 
383 
		while ( !IS_NULL_list ( a ) ) {
 - 
 
384 
		    ARGUMENT_P arg = DEREF_ptr ( HEAD_list ( a ) ) ;
 - 
 
385 
		    s = DEREF_ptr ( arg_type ( arg ) ) ;
 - 
 
386 
		    p = derived_types ( s, p ) ;
 - 
 
387 
		    a = TAIL_list ( a ) ;
 - 
 
388 
		}
 - 
 
389 
		m = TAIL_list ( m ) ;
 - 
 
390 
	    }
 - 
 
391 
	    break ;
 - 
 
392 
	}
 - 
 
393 
 
 - 
 
394 
	case type_list_tag :
 - 
 
395 
	case type_ptr_tag :
 - 
 
396 
	case type_stack_tag :
 - 
 
397 
	case type_vec_tag :
 - 
 
398 
	case type_vec_ptr_tag : {
 - 
 
399 
	    /* Pointer subtypes */
 - 
 
400 
	    TYPE_P s = DEREF_ptr ( type_ptr_etc_sub ( t0 ) ) ;
 - 
 
401 
	    p = derived_types ( s, p ) ;
 - 
 
402 
	    break ;
 - 
 
403 
	}
 - 
 
404 
    }
 - 
 
405 
    return ( p ) ;
 - 
 
406 
}
 - 
 
407 
 
 - 
 
408 
 
 - 
 
409 
/*
 - 
 
410 
    IMPORT A LIST OF TYPES
 - 
 
411 
 
 - 
 
412 
    This routine imports all the types in the list t.
 - 
 
413 
*/
 - 
 
414 
 
 - 
 
415 
static void import_type_list
 - 
 
416 
    PROTO_N ( ( t ) )
 - 
 
417 
    PROTO_T ( LIST ( TYPE_P ) t )
 - 
 
418 
{
 - 
 
419 
    while ( !IS_NULL_list ( t ) ) {
 447 
    while (!IS_NULL_list(t)) {
420 
	TYPE_P s = DEREF_ptr ( HEAD_list ( t ) ) ;
 448 
	TYPE_P s = DEREF_ptr(HEAD_list(t));
421 
	TYPE s0 = DEREF_type ( s ) ;
 449 
	TYPE s0 = DEREF_type(s);
422 
	unsigned tag = TAG_type ( s0 ) ;
 450 
	unsigned tag = TAG_type(s0);
423 
	switch ( tag ) {
 451 
	switch (tag) {
424 
	    case type_primitive_tag : {
 452 
	    case type_primitive_tag: {
425 
		PRIMITIVE_P p = DEREF_ptr ( type_primitive_prim ( s0 ) ) ;
 453 
		PRIMITIVE_P p = DEREF_ptr(type_primitive_prim(s0));
426 
		CONS_ptr ( p, algebra->primitives, algebra->primitives ) ;
 454 
		CONS_ptr(p, algebra->primitives, algebra->primitives);
427 
		goto register_lab ;
 455 
		goto register_lab;
428 
	    }
 456 
	    }
429 
	    case type_ident_tag : {
 457 
	    case type_ident_tag: {
430 
		IDENTITY_P p = DEREF_ptr ( type_ident_id ( s0 ) ) ;
 458 
		IDENTITY_P p = DEREF_ptr(type_ident_id(s0));
431 
		CONS_ptr ( p, algebra->identities, algebra->identities ) ;
 459 
		CONS_ptr(p, algebra->identities, algebra->identities);
432 
		goto register_lab ;
 460 
		goto register_lab;
433 
	    }
 461 
	    }
434 
	    case type_enumeration_tag : {
 462 
	    case type_enumeration_tag: {
435 
		ENUM_P p = DEREF_ptr ( type_enumeration_en ( s0 ) ) ;
 463 
		ENUM_P p = DEREF_ptr(type_enumeration_en(s0));
436 
		CONS_ptr ( p, algebra->enumerations, algebra->enumerations ) ;
 464 
		CONS_ptr(p, algebra->enumerations, algebra->enumerations);
437 
		goto register_lab ;
 465 
		goto register_lab;
438 
	    }
 466 
	    }
439 
	    case type_structure_tag : {
 467 
	    case type_structure_tag: {
440 
		STRUCTURE_P p = DEREF_ptr ( type_structure_struc ( s0 ) ) ;
 468 
		STRUCTURE_P p = DEREF_ptr(type_structure_struc(s0));
441 
		CONS_ptr ( p, algebra->structures, algebra->structures ) ;
 469 
		CONS_ptr(p, algebra->structures, algebra->structures);
442 
		goto register_lab ;
 470 
		goto register_lab;
443 
	    }
 471 
	    }
444 
	    case type_onion_tag : {
 472 
	    case type_onion_tag: {
445 
		UNION_P p = DEREF_ptr ( type_onion_un ( s0 ) ) ;
 473 
		UNION_P p = DEREF_ptr(type_onion_un(s0));
446 
		CONS_ptr ( p, algebra->unions, algebra->unions ) ;
 474 
		CONS_ptr(p, algebra->unions, algebra->unions);
447 
		goto register_lab ;
 475 
		goto register_lab;
448 
	    }
 476 
	    }
449 
	    register_lab : {
 477 
	    register_lab : {
450 
		TYPE_P r = register_type ( s ) ;
 478 
		TYPE_P r = register_type(s);
451 
		if ( !EQ_ptr ( r, s ) ) {
 479 
		if (!EQ_ptr(r, s)) {
452 
		    error ( ERROR_SERIOUS,
 480 
		    error(ERROR_SERIOUS,
453 
			    "Can't import previously used type %s",
 481 
			    "Can't import previously used type %s",
454 
			    name_type ( s ) ) ;
 482 
			    name_type(s));
455 
		}
 483 
		}
456 
		break ;
 484 
		break;
457 
	    }
 485 
	    }
458 
	    default : {
 486 
	    default : {
459 
		TYPE_P p = DEREF_ptr ( type_ptr_etc_sub ( s0 ) ) ;
 487 
		TYPE_P p = DEREF_ptr(type_ptr_etc_sub(s0));
460 
		( void ) compound_type ( tag, p, 0 ) ;
 488 
		(void)compound_type(tag, p, 0);
461 
		break ;
 489 
		break;
462 
	    }
 - 
 
463 
	}
 - 
 
464 
	t = TAIL_list ( t ) ;
 - 
 
465 
    }
 - 
 
466 
    return ;
 - 
 
467 
}
 - 
 
468 
 
 - 
 
469 
 
 - 
 
470 
/*
 - 
 
471 
    IMPORT A SINGLE ITEM FROM AN ALGEBRA
 - 
 
472 
 
 - 
 
473 
    This routine imports the type named nm from the algebra alg into the
 - 
 
474 
    current algebra.
 - 
 
475 
*/
 - 
 
476 
 
 - 
 
477 
void import_type
 - 
 
478 
    PROTO_N ( ( alg, nm ) )
 - 
 
479 
    PROTO_T ( char *alg X char *nm )
 - 
 
480 
{
 - 
 
481 
    TYPE_P t ;
 - 
 
482 
    LIST ( TYPE_P ) p ;
 - 
 
483 
    ALGEBRA_DEFN *a = find_algebra ( alg ) ;
 - 
 
484 
    if ( a == NULL ) {
 - 
 
485 
	error ( ERROR_SERIOUS, "Algebra %s not defined", alg ) ;
 - 
 
486 
	return ;
 - 
 
487 
    } else if ( a == algebra ) {
 - 
 
488 
	error ( ERROR_SERIOUS, "Can't import from current algebra" ) ;
 - 
 
489 
	return ;
 - 
 
490 
    }
 - 
 
491 
    t = find_type ( a, nm ) ;
 - 
 
492 
    if ( IS_type_undef ( DEREF_type ( t ) ) ) {
 - 
 
493 
	error ( ERROR_SERIOUS, "Type %s::%s not defined", alg, nm ) ;
 - 
 
494 
	return ;
 - 
 
495 
    }
 - 
 
496 
    p = derived_types ( t, NULL_list ( TYPE_P ) ) ;
 - 
 
497 
    import_type_list ( p ) ;
 - 
 
498 
    while ( !IS_NULL_list ( p ) ) {
 - 
 
499 
	DESTROY_CONS_ptr ( destroy_calculus, t, p, p ) ;
 - 
 
500 
	UNUSED ( t ) ;
 - 
 
501 
    }
 - 
 
502 
    return ;
 - 
 
503 
}
 - 
 
504 
 
 - 
 
505 
 
 - 
 
506 
/*
 - 
 
507 
    IMPORT AN ENTIRE ALGEBRA
 - 
 
508 
 
 - 
 
509 
    This routine imports all the types in the algebra alg into the current
 - 
 
510 
    algebra.
 - 
 
511 
*/
 - 
 
512 
 
 - 
 
513 
void import_algebra
 - 
 
514 
    PROTO_N ( ( alg ) )
 - 
 
515 
    PROTO_T ( char *alg )
 - 
 
516 
{
 - 
 
517 
    ALGEBRA_DEFN *a = find_algebra ( alg ) ;
 - 
 
518 
    if ( a == NULL ) {
 - 
 
519 
	error ( ERROR_SERIOUS, "Algebra %s not defined", alg ) ;
 - 
 
520 
	return ;
 - 
 
521 
    } else if ( a == algebra ) {
 - 
 
522 
	error ( ERROR_SERIOUS, "Can't import from current algebra" ) ;
 - 
 
523 
	return ;
 - 
 
524 
    }
 - 
 
525 
    import_type_list ( a->types ) ;
 - 
 
526 
    return ;
 - 
 
527 
}
 - 
 
528 
 
 - 
 
529 
 
 - 
 
530 
/*
 - 
 
531 
    FIND THE SIZE OF A TYPE
 - 
 
532 
 
 - 
 
533 
    This routine calculates the size of the type t.
 - 
 
534 
*/
 - 
 
535 
 
 - 
 
536 
int size_type
 - 
 
537 
    PROTO_N ( ( t, depth ) )
 - 
 
538 
    PROTO_T ( TYPE_P t X int depth )
 - 
 
539 
{
 - 
 
540 
    TYPE t0 = DEREF_type ( t ) ;
 - 
 
541 
    int sz = DEREF_int ( type_size ( t0 ) ) ;
 - 
 
542 
    if ( sz ) return ( sz ) ;
 - 
 
543 
 
 - 
 
544 
    if ( depth > MAX_TYPE_DEPTH ) {
 - 
 
545 
	error ( ERROR_SERIOUS, "Cyclic type definition involving %s",
 - 
 
546 
		name_type ( t ) ) ;
 - 
 
547 
	return ( 1 ) ;
 - 
 
548 
    }
 - 
 
549 
 
 - 
 
550 
    switch ( TAG_type ( t0 ) ) {
 - 
 
551 
	case type_ident_tag : {
 - 
 
552 
	    IDENTITY_P i = DEREF_ptr ( type_ident_id ( t0 ) ) ;
 - 
 
553 
	    TYPE_P_P s = ident_defn ( i ) ;
 - 
 
554 
	    sz = size_type ( DEREF_ptr ( s ), depth + 1 ) ;
 - 
 
555 
	    break ;
 - 
 
556 
	}
 - 
 
557 
 
 - 
 
558 
	case type_structure_tag : {
 - 
 
559 
	    STRUCTURE_P str = DEREF_ptr ( type_structure_struc ( t0 ) ) ;
 - 
 
560 
	    LIST ( COMPONENT_P ) c = DEREF_list ( str_defn ( str ) ) ;
 - 
 
561 
	    sz = 0 ;
 - 
 
562 
	    while ( !IS_NULL_list ( c ) ) {
 - 
 
563 
		TYPE_P_P s ;
 - 
 
564 
		s = cmp_type ( DEREF_ptr ( HEAD_list ( c ) ) ) ;
 - 
 
565 
		sz += size_type ( DEREF_ptr ( s ), depth + 1 ) ;
 - 
 
566 
		c = TAIL_list ( c ) ;
 - 
 
567 
	    }
 490 
	    }
568 
	    break ;
 - 
 
569 
	}
 - 
 
570 
 
 - 
 
571 
	case type_primitive_tag : sz = SIZE_PRIM ; break ;
 - 
 
572 
	case type_enumeration_tag : sz = SIZE_ENUM ; break ;
 - 
 
573 
	case type_onion_tag : sz = SIZE_UNION ; break ;
 - 
 
574 
	case type_ptr_tag : sz = SIZE_PTR ; break ;
 - 
 
575 
	case type_list_tag : sz = SIZE_LIST ; break ;
 - 
 
576 
	case type_stack_tag : sz = SIZE_STACK ; break ;
 - 
 
577 
	case type_vec_tag : sz = SIZE_VEC ; break ;
 - 
 
578 
	case type_vec_ptr_tag : sz = SIZE_VEC_PTR ; break ;
 - 
 
579 
 
 - 
 
580 
	default : {
 - 
 
581 
	    error ( ERROR_SERIOUS, "Can't take size of type %s",
 - 
 
582 
		    name_type ( t ) ) ;
 - 
 
583 
	    sz = 1 ;
 - 
 
584 
	    break ;
 - 
 
585 
	}
 491 
	}
- 
 
 492 
	t = TAIL_list(t);
586 
    }
 493 
    }
587 
    return ( sz ) ;
 494 
    return;
588 
}
 495 
}
589 
 
 496 
 
590 
 
 497 
 
591 
/*
 498 
/*
592 
    FIND THE NAME OF A TYPE
 499 
 * IMPORT A SINGLE ITEM FROM AN ALGEBRA
- 
 
 500 
 *
- 
 
 501 
 * This routine imports the type named nm from the algebra alg into the
- 
 
 502 
 * current algebra.
- 
 
 503 
 */
593 
 
 504 
 
594 
    This routine finds the long name of the type t.
 - 
 
595 
*/
 505 
void
596 
 
 - 
 
597 
char *name_type
 - 
 
598 
    PROTO_N ( ( t ) )
 - 
 
599 
    PROTO_T ( TYPE_P t )
 506 
import_type(char *alg, char *nm)
600 
{
 507 
{
601 
    CLASS_ID_P id ;
 508 
    TYPE_P t;
602 
    TYPE t0 = DEREF_type ( t ) ;
 509 
    LIST(TYPE_P)p;
603 
    switch ( TAG_type ( t0 ) ) EXHAUSTIVE {
 510 
    ALGEBRA_DEFN *a = find_algebra(alg);
604 
	case type_primitive_tag : {
 511 
    if (a == NULL) {
605 
	    PRIMITIVE_P a = DEREF_ptr ( type_primitive_prim ( t0 ) ) ;
 - 
 
606 
	    id = DEREF_ptr ( prim_id ( a ) ) ;
 512 
	error(ERROR_SERIOUS, "Algebra %s not defined", alg);
607 
	    break ;
 513 
	return;
608 
	}
 - 
 
609 
	case type_ident_tag : {
 514 
    } else if (a == algebra) {
610 
	    IDENTITY_P a = DEREF_ptr ( type_ident_id ( t0 ) ) ;
 515 
	error(ERROR_SERIOUS, "Can't import from current algebra");
611 
	    id = DEREF_ptr ( ident_id ( a ) ) ;
 - 
 
612 
	    break ;
 516 
	return;
613 
	}
 517 
    }
614 
	case type_enumeration_tag : {
 518 
    t = find_type(a, nm);
615 
	    ENUM_P a = DEREF_ptr ( type_enumeration_en ( t0 ) ) ;
 519 
    if (IS_type_undef(DEREF_type(t))) {
616 
	    id = DEREF_ptr ( en_id ( a ) ) ;
 520 
	error(ERROR_SERIOUS, "Type %s::%s not defined", alg, nm);
617 
	    break ;
 521 
	return;
618 
	}
 522 
    }
- 
 
 523 
    p = derived_types(t, NULL_list(TYPE_P));
619 
	case type_structure_tag : {
 524 
    import_type_list(p);
620 
	    STRUCTURE_P a = DEREF_ptr ( type_structure_struc ( t0 ) ) ;
 525 
    while (!IS_NULL_list(p)) {
621 
	    id = DEREF_ptr ( str_id ( a ) ) ;
 526 
	DESTROY_CONS_ptr(destroy_calculus, t, p, p);
622 
	    break ;
 527 
	UNUSED(t);
623 
	}
 528 
    }
624 
	case type_onion_tag : {
 - 
 
625 
	    UNION_P a = DEREF_ptr ( type_onion_un ( t0 ) ) ;
 - 
 
626 
	    id = DEREF_ptr ( un_id ( a ) ) ;
 - 
 
627 
	    break ;
 529 
    return;
628 
	}
 530 
}
629 
	case type_quote_tag : {
 - 
 
630 
	    char *a = DEREF_string ( type_quote_defn ( t0 ) ) ;
 - 
 
631 
	    return ( a ) ;
 - 
 
- 
 
 531 
 
- 
 
 532 
 
632 
	}
 533 
/*
633 
	case type_ptr_tag : {
 - 
 
634 
	    return ( "PTR" ) ;
 534 
 * IMPORT AN ENTIRE ALGEBRA
635 
	}
 535 
 *
636 
	case type_list_tag : {
 536 
 * This routine imports all the types in the algebra alg into the current
637 
	    return ( "LIST" ) ;
 537 
 * algebra.
638 
	}
 538 
 */
639 
	case type_stack_tag : {
 - 
 
640 
	    return ( "STACK" ) ;
 - 
 
641 
	}
 539 
 
642 
	case type_vec_tag : {
 540 
void
643 
	    return ( "VEC" ) ;
 541 
import_algebra(char *alg)
644 
	}
 542 
{
645 
	case type_vec_ptr_tag : {
 543 
    ALGEBRA_DEFN *a = find_algebra(alg);
646 
	    return ( "VEC_PTR" ) ;
 544 
    if (a == NULL) {
- 
 
 545 
	error(ERROR_SERIOUS, "Algebra %s not defined", alg);
647 
	}
 546 
	return;
648 
	case type_undef_tag : {
 547 
    } else if (a == algebra) {
649 
	    char *a = DEREF_string ( type_undef_name ( t0 ) ) ;
 548 
	error(ERROR_SERIOUS, "Can't import from current algebra");
650 
	    return ( a ) ;
 549 
	return;
651 
	}
 - 
 
652 
    }
 550 
    }
- 
 
 551 
    import_type_list(a->types);
- 
 
 552 
    return;
- 
 
 553 
}
- 
 
 554 
 
- 
 
 555 
 
- 
 
 556 
/*
- 
 
 557 
 * FIND THE SIZE OF A TYPE
- 
 
 558 
 *
- 
 
 559 
 * This routine calculates the size of the type t.
- 
 
 560 
 */
- 
 
 561 
 
- 
 
 562 
int
- 
 
 563 
size_type(TYPE_P t, int depth)
- 
 
 564 
{
- 
 
 565 
    TYPE t0 = DEREF_type(t);
- 
 
 566 
    int sz = DEREF_int(type_size(t0));
653 
    last_id = id ;
 567 
    if (sz) {
- 
 
 568 
	    return(sz);
- 
 
 569 
    }
- 
 
 570 
 
- 
 
 571 
    if (depth > MAX_TYPE_DEPTH) {
- 
 
 572 
	error(ERROR_SERIOUS, "Cyclic type definition involving %s",
- 
 
 573 
	      name_type(t));
- 
 
 574 
	return(1);
- 
 
 575 
    }
- 
 
 576 
 
- 
 
 577 
    switch (TAG_type(t0)) {
- 
 
 578 
	case type_ident_tag: {
654 
    return ( DEREF_string ( cid_name ( id ) ) ) ;
 579 
	    IDENTITY_P i = DEREF_ptr(type_ident_id(t0));
- 
 
 580 
	    TYPE_P_P s = ident_defn(i);
- 
 
 581 
	    sz = size_type(DEREF_ptr(s), depth + 1);
- 
 
 582 
	    break;
- 
 
 583 
	}
- 
 
 584 
 
- 
 
 585 
	case type_structure_tag: {
- 
 
 586 
	    STRUCTURE_P str = DEREF_ptr(type_structure_struc(t0));
- 
 
 587 
	    LIST(COMPONENT_P)c = DEREF_list(str_defn(str));
- 
 
 588 
	    sz = 0;
- 
 
 589 
	    while (!IS_NULL_list(c)) {
- 
 
 590 
		TYPE_P_P s;
- 
 
 591 
		s = cmp_type(DEREF_ptr(HEAD_list(c)));
- 
 
 592 
		sz += size_type(DEREF_ptr(s), depth + 1);
- 
 
 593 
		c = TAIL_list(c);
- 
 
 594 
	    }
- 
 
 595 
	    break;
- 
 
 596 
	}
- 
 
 597 
 
- 
 
 598 
	case type_primitive_tag: sz = SIZE_PRIM; break;
- 
 
 599 
	case type_enumeration_tag: sz = SIZE_ENUM; break;
- 
 
 600 
	case type_onion_tag: sz = SIZE_UNION; break;
- 
 
 601 
	case type_ptr_tag: sz = SIZE_PTR; break;
- 
 
 602 
	case type_list_tag: sz = SIZE_LIST; break;
- 
 
 603 
	case type_stack_tag: sz = SIZE_STACK; break;
- 
 
 604 
	case type_vec_tag: sz = SIZE_VEC; break;
- 
 
 605 
	case type_vec_ptr_tag: sz = SIZE_VEC_PTR; break;
- 
 
 606 
 
- 
 
 607 
	default : {
- 
 
 608 
	    error(ERROR_SERIOUS, "Can't take size of type %s", name_type(t));
- 
 
 609 
	    sz = 1;
- 
 
 610 
	    break;
- 
 
 611 
	}
- 
 
 612 
    }
- 
 
 613 
    return(sz);
655 
}
 614 
}
656 
 
 615 
 
657 
 
 616 
 
658 
/*
 617 
/*
659 
    FIND THE AUXILIARY NAME OF A TYPE
 618 
 * FIND THE NAME OF A TYPE
- 
 
 619 
 *
- 
 
 620 
 * This routine finds the long name of the type t.
- 
 
 621 
 */
660 
 
 622 
 
661 
    This routine finds the short name of the type t.
 - 
 
662 
*/
 - 
 
663 
 
 - 
 
664 
char *name_aux_type
 623 
char *
665 
    PROTO_N ( ( t ) )
 - 
 
666 
    PROTO_T ( TYPE_P t )
 624 
name_type(TYPE_P t)
667 
{
 625 
{
668 
    CLASS_ID_P id ;
 626 
    CLASS_ID_P id;
669 
    TYPE t0 = DEREF_type ( t ) ;
 627 
    TYPE t0 = DEREF_type(t);
670 
    switch ( TAG_type ( t0 ) ) EXHAUSTIVE {
 628 
    switch (TAG_type(t0))EXHAUSTIVE {
671 
	case type_primitive_tag : {
 629 
	case type_primitive_tag: {
672 
	    PRIMITIVE_P a = DEREF_ptr ( type_primitive_prim ( t0 ) ) ;
 630 
	    PRIMITIVE_P a = DEREF_ptr(type_primitive_prim(t0));
673 
	    id = DEREF_ptr ( prim_id ( a ) ) ;
 631 
	    id = DEREF_ptr(prim_id(a));
- 
 
 632 
	    break;
- 
 
 633 
	}
- 
 
 634 
	case type_ident_tag: {
- 
 
 635 
	    IDENTITY_P a = DEREF_ptr(type_ident_id(t0));
- 
 
 636 
	    id = DEREF_ptr(ident_id(a));
- 
 
 637 
	    break;
- 
 
 638 
	}
- 
 
 639 
	case type_enumeration_tag: {
- 
 
 640 
	    ENUM_P a = DEREF_ptr(type_enumeration_en(t0));
- 
 
 641 
	    id = DEREF_ptr(en_id(a));
- 
 
 642 
	    break;
- 
 
 643 
	}
- 
 
 644 
	case type_structure_tag: {
- 
 
 645 
	    STRUCTURE_P a = DEREF_ptr(type_structure_struc(t0));
- 
 
 646 
	    id = DEREF_ptr(str_id(a));
- 
 
 647 
	    break;
- 
 
 648 
	}
- 
 
 649 
	case type_onion_tag: {
- 
 
 650 
	    UNION_P a = DEREF_ptr(type_onion_un(t0));
- 
 
 651 
	    id = DEREF_ptr(un_id(a));
674 
	    break ;
 652 
	    break;
- 
 
 653 
	}
- 
 
 654 
	case type_quote_tag: {
- 
 
 655 
	    char *a = DEREF_string(type_quote_defn(t0));
- 
 
 656 
	    return(a);
- 
 
 657 
	}
- 
 
 658 
	case type_ptr_tag: {
- 
 
 659 
	    return("PTR");
675 
	}
 660 
	}
676 
	case type_ident_tag : {
 661 
	case type_list_tag: {
677 
	    IDENTITY_P a = DEREF_ptr ( type_ident_id ( t0 ) ) ;
 662 
	    return("LIST");
678 
	    return ( name_aux_type ( DEREF_ptr ( ident_defn ( a ) ) ) ) ;
 - 
 
679 
	}
 663 
	}
680 
	case type_enumeration_tag : {
 664 
	case type_stack_tag: {
681 
	    ENUM_P a = DEREF_ptr ( type_enumeration_en ( t0 ) ) ;
 - 
 
682 
	    id = DEREF_ptr ( en_id ( a ) ) ;
 - 
 
683 
	    break ;
 665 
	    return("STACK");
684 
	}
 666 
	}
685 
	case type_structure_tag : {
 667 
	case type_vec_tag: {
686 
	    STRUCTURE_P a = DEREF_ptr ( type_structure_struc ( t0 ) ) ;
 - 
 
687 
	    id = DEREF_ptr ( str_id ( a ) ) ;
 - 
 
688 
	    break ;
 668 
	    return("VEC");
689 
	}
 669 
	}
690 
	case type_onion_tag : {
 670 
	case type_vec_ptr_tag: {
691 
	    UNION_P a = DEREF_ptr ( type_onion_un ( t0 ) ) ;
 - 
 
692 
	    id = DEREF_ptr ( un_id ( a ) ) ;
 - 
 
693 
	    break ;
 671 
	    return("VEC_PTR");
694 
	}
 672 
	}
695 
	case type_quote_tag : {
 673 
	case type_undef_tag: {
696 
	    char *a = DEREF_string ( type_quote_defn ( t0 ) ) ;
 674 
	    char *a = DEREF_string(type_undef_name(t0));
697 
	    return ( a ) ;
 675 
	    return(a);
698 
	}
 676 
	}
- 
 
 677 
    }
- 
 
 678 
    last_id = id;
- 
 
 679 
    return(DEREF_string(cid_name(id)));
- 
 
 680 
}
- 
 
 681 
 
- 
 
 682 
 
- 
 
 683 
/*
- 
 
 684 
 * FIND THE AUXILIARY NAME OF A TYPE
- 
 
 685 
 *
- 
 
 686 
 * This routine finds the short name of the type t.
- 
 
 687 
 */
- 
 
 688 
 
- 
 
 689 
char *
- 
 
 690 
name_aux_type(TYPE_P t)
- 
 
 691 
{
- 
 
 692 
    CLASS_ID_P id;
- 
 
 693 
    TYPE t0 = DEREF_type(t);
- 
 
 694 
    switch (TAG_type(t0))EXHAUSTIVE {
- 
 
 695 
	case type_primitive_tag: {
- 
 
 696 
	    PRIMITIVE_P a = DEREF_ptr(type_primitive_prim(t0));
- 
 
 697 
	    id = DEREF_ptr(prim_id(a));
- 
 
 698 
	    break;
- 
 
 699 
	}
- 
 
 700 
	case type_ident_tag: {
- 
 
 701 
	    IDENTITY_P a = DEREF_ptr(type_ident_id(t0));
- 
 
 702 
	    return(name_aux_type(DEREF_ptr(ident_defn(a))));
- 
 
 703 
	}
- 
 
 704 
	case type_enumeration_tag: {
- 
 
 705 
	    ENUM_P a = DEREF_ptr(type_enumeration_en(t0));
- 
 
 706 
	    id = DEREF_ptr(en_id(a));
- 
 
 707 
	    break;
- 
 
 708 
	}
- 
 
 709 
	case type_structure_tag: {
- 
 
 710 
	    STRUCTURE_P a = DEREF_ptr(type_structure_struc(t0));
- 
 
 711 
	    id = DEREF_ptr(str_id(a));
- 
 
 712 
	    break;
- 
 
 713 
	}
- 
 
 714 
	case type_onion_tag: {
- 
 
 715 
	    UNION_P a = DEREF_ptr(type_onion_un(t0));
- 
 
 716 
	    id = DEREF_ptr(un_id(a));
- 
 
 717 
	    break;
- 
 
 718 
	}
- 
 
 719 
	case type_quote_tag: {
- 
 
 720 
	    char *a = DEREF_string(type_quote_defn(t0));
- 
 
 721 
	    return(a);
- 
 
 722 
	}
699 
	case type_ptr_tag : {
 723 
	case type_ptr_tag: {
700 
	    return ( "ptr" ) ;
 724 
	    return("ptr");
701 
	}
 725 
	}
702 
	case type_list_tag : {
 726 
	case type_list_tag: {
703 
	    return ( "list" ) ;
 727 
	    return("list");
704 
	}
 728 
	}
705 
	case type_stack_tag : {
 729 
	case type_stack_tag: {
706 
	    return ( "stack" ) ;
 730 
	    return("stack");
707 
	}
 731 
	}
708 
	case type_vec_tag : {
 732 
	case type_vec_tag: {
709 
	    return ( "vec" ) ;
 733 
	    return("vec");
710 
	}
 734 
	}
711 
	case type_vec_ptr_tag : {
 735 
	case type_vec_ptr_tag: {
712 
	    return ( "vec_ptr" ) ;
 736 
	    return("vec_ptr");
713 
	}
 737 
	}
714 
	case type_undef_tag : {
 738 
	case type_undef_tag: {
715 
	    char *a = DEREF_string ( type_undef_name ( t0 ) ) ;
 739 
	    char *a = DEREF_string(type_undef_name(t0));
716 
	    return ( a ) ;
 740 
	    return(a);
717 
	}
 741 
	}
718 
    }
 742 
    }
719 
    last_id = id ;
 743 
    last_id = id;
720 
    return ( DEREF_string ( cid_name_aux ( id ) ) ) ;
 744 
    return(DEREF_string(cid_name_aux(id)));
721 
}
 745 
}
722 
 
 746 
 
723 
 
 747 
 
724 
/*
 748 
/*
725 
    CHECK FOR COMPLEX TYPES
 749 
 * CHECK FOR COMPLEX TYPES
726 
 
 750 
 *
727 
    This routine checks whether a type is complex in the sense that it
 751 
 * This routine checks whether a type is complex in the sense that it
728 
    requires the statement versions of COPY and DEREF rather than the
 752 
 * requires the statement versions of COPY and DEREF rather than the
729 
    expression versions.
 753 
 * expression versions.
730 
*/
 754 
 */
731 
 
 755 
 
732 
int is_complex_type
 756 
int
733 
    PROTO_N ( ( t ) )
 - 
 
734 
    PROTO_T ( TYPE_P t )
 757 
is_complex_type(TYPE_P t)
735 
{
 758 
{
736 
    TYPE t0 = DEREF_type ( t ) ;
 759 
    TYPE t0 = DEREF_type(t);
737 
    switch ( TAG_type ( t0 ) ) {
 760 
    switch (TAG_type(t0)) {
738 
	case type_structure_tag :
 761 
	case type_structure_tag:
739 
	case type_vec_tag :
 762 
	case type_vec_tag:
740 
	case type_vec_ptr_tag : {
 763 
	case type_vec_ptr_tag: {
741 
	    return ( 1 ) ;
 764 
	    return(1);
742 
	}
 765 
	}
743 
	case type_ident_tag : {
 766 
	case type_ident_tag: {
744 
	    IDENTITY_P r = DEREF_ptr ( type_ident_id ( t0 ) ) ;
 767 
	    IDENTITY_P r = DEREF_ptr(type_ident_id(t0));
745 
	    TYPE_P s = DEREF_ptr ( ident_defn ( r ) ) ;
 768 
	    TYPE_P s = DEREF_ptr(ident_defn(r));
746 
	    return ( is_complex_type ( s ) ) ;
 769 
	    return(is_complex_type(s));
747 
	}
 770 
	}
748 
    }
 771 
    }
749 
    return ( 0 ) ;
 772 
    return(0);
750 
}
 773 
}