Rev 2 | Blame | Compare with Previous | Last modification | View Log | RSS feed
/*
Crown Copyright (c) 1997
This TenDRA(r) Computer Program is subject to Copyright
owned by the United Kingdom Secretary of State for Defence
acting through the Defence Evaluation and Research Agency
(DERA). It is made available to Recipients with a
royalty-free licence for its use, reproduction, transfer
to other parties and amendment for any purpose not excluding
product development provided that any such use et cetera
shall be deemed to be acceptance of the following conditions:-
(1) Its Recipients shall ensure that this Notice is
reproduced upon any copies or amended versions of it;
(2) Any amended version of it shall be clearly marked to
show both the nature of and the organisation responsible
for the relevant amendment or amendments;
(3) Its onward transfer from a recipient to another
party shall be deemed to be that party's acceptance of
these conditions;
(4) DERA gives no warranty or assurance as to its
quality or suitability for any purpose and DERA accepts
no liability whatsoever in relation to any use to which
it may be put.
*/
#include "config.h"
#include "calculus.h"
#include "error.h"
#include "common.h"
#include "type_ops.h"
#include "xalloc.h"
/*
TYPE REPRESENTING A LIST OF ALGEBRAS
This type is used to represent the list of all algebras.
*/
typedef struct ALGEBRA_LIST_tag {
ALGEBRA_DEFN alg ;
struct ALGEBRA_LIST_tag *next ;
} ALGEBRA_LIST ;
/*
CURRENT ALGEBRA
The variable algebra holds all the information on the algebra read
from the input file. The list all_algebras contains a list of all
the algebras defined.
*/
ALGEBRA_DEFN *algebra = NULL ;
static ALGEBRA_LIST *all_algebras = NULL ;
/*
CREATE A NEW ALGEBRA
This routine allocates and initialises a new algebra structure.
*/
void new_algebra
PROTO_Z ()
{
ALGEBRA_LIST *p = xmalloc_nof ( ALGEBRA_LIST, 1 ) ;
p->alg.name = "ALGEBRA" ;
p->alg.major_no = 1 ;
p->alg.minor_no = 0 ;
p->alg.primitives = NULL_list ( PRIMITIVE_P ) ;
p->alg.identities = NULL_list ( IDENTITY_P ) ;
p->alg.enumerations = NULL_list ( ENUM_P ) ;
p->alg.structures = NULL_list ( STRUCTURE_P ) ;
p->alg.unions = NULL_list ( UNION_P ) ;
p->alg.types = NULL_list ( TYPE_P ) ;
p->next = all_algebras ;
all_algebras = p ;
algebra = &( p->alg ) ;
return ;
}
/*
LOOK UP AN ALGEBRA
This routine looks up the algebra named nm. It returns null if the
algebra has not been defined.
*/
ALGEBRA_DEFN *find_algebra
PROTO_N ( ( nm ) )
PROTO_T ( char *nm )
{
ALGEBRA_LIST *p ;
for ( p = all_algebras ; p != NULL ; p = p->next ) {
if ( streq ( p->alg.name, nm ) ) return ( &( p->alg ) ) ;
}
return ( NULL ) ;
}
/*
LAST IDENTIFIER
This variable is set by name_type and name_aux_type to the identifier
of the last non-composite type looked up.
*/
static CLASS_ID_P last_id = NULL_ptr ( CLASS_ID ) ;
/*
REGISTER A TYPE
This routine adds the type t to the list of all types.
*/
TYPE_P register_type
PROTO_N ( ( t ) )
PROTO_T ( TYPE_P t )
{
char *nm = name_type ( t ) ;
CLASS_ID_P id = last_id ;
LIST ( TYPE_P ) r = algebra->types ;
while ( !IS_NULL_list ( r ) ) {
TYPE_P s = DEREF_ptr ( HEAD_list ( r ) ) ;
if ( streq ( name_type ( s ), nm ) ) {
/* Check for multiple definition */
if ( !IS_type_undef ( DEREF_type ( s ) ) ) {
char *fn1 = DEREF_string ( cid_file ( id ) ) ;
int ln1 = DEREF_int ( cid_line ( id ) ) ;
char *fn2 = DEREF_string ( cid_file ( last_id ) ) ;
int ln2 = DEREF_int ( cid_line ( last_id ) ) ;
if ( fn2 == crt_file_name ) {
char *fn = fn1 ;
int ln = ln1 ;
fn1 = fn2 ;
ln1 = ln2 ;
fn2 = fn ;
ln2 = ln ;
}
error_posn ( ERROR_SERIOUS, fn1, ln1,
"Type %s already defined (at %s, line %d)",
nm, fn2, ln2 ) ;
}
COPY_type ( s, DEREF_type ( t ) ) ;
return ( s ) ;
}
r = TAIL_list ( r ) ;
}
CONS_ptr ( t, algebra->types, algebra->types ) ;
return ( t ) ;
}
/*
LOOK UP A NAMED TYPE
This routine looks up the type named nm in the list of all types
associated with the algebra alg. The type is created if necessary,
and the result is returned.
*/
TYPE_P find_type
PROTO_N ( ( alg, nm ) )
PROTO_T ( ALGEBRA_DEFN *alg X char *nm )
{
TYPE s0 ;
TYPE_P s ;
LIST ( TYPE_P ) t = alg->types ;
while ( !IS_NULL_list ( t ) ) {
s = DEREF_ptr ( HEAD_list ( t ) ) ;
if ( streq ( name_type ( s ), nm ) ) return ( s ) ;
t = TAIL_list ( t ) ;
}
s = MAKE_ptr ( SIZE_type ) ;
MAKE_type_undef ( 0, nm, s0 ) ;
COPY_type ( s, s0 ) ;
s = register_type ( s ) ;
return ( s ) ;
}
/*
DOES A TYPE INVOLVE AN IDENTITY
This routine checks whether the type t is an identity or a compound
type derived from an identity.
*/
int is_identity_type
PROTO_N ( ( t ) )
PROTO_T ( TYPE_P t )
{
TYPE t0 = DEREF_type ( t ) ;
while ( IS_type_ptr_etc ( t0 ) ) {
t0 = DEREF_type ( DEREF_ptr ( type_ptr_etc_sub ( t0 ) ) ) ;
}
return ( IS_type_ident ( t0 ) ) ;
}
/*
DEAL WITH COMPOUND TYPES INVOLVING IDENTITIES
From the point of view of the list of all types, identity types are
distinct from their definitions. This routine is called after creating
a compound type, r, to ensure that the corresponding type with any
identities replaced by their definition is also created.
*/
static TYPE_P compound_identity
PROTO_N ( ( r, depth ) )
PROTO_T ( TYPE_P r X int depth )
{
TYPE r0 = DEREF_type ( r ) ;
if ( depth > MAX_TYPE_DEPTH ) {
error ( ERROR_SERIOUS, "Cyclic type definition involving %s",
name_type ( r ) ) ;
return ( NULL_ptr ( TYPE ) ) ;
}
if ( IS_type_ident ( r0 ) ) {
IDENTITY_P a = DEREF_ptr ( type_ident_id ( DEREF_type ( r ) ) ) ;
TYPE_P s = DEREF_ptr ( ident_defn ( a ) ) ;
return ( s ) ;
}
if ( IS_type_ptr_etc ( r0 ) ) {
unsigned tag = TAG_type ( r0 ) ;
TYPE_P s = DEREF_ptr ( type_ptr_etc_sub ( r0 ) ) ;
s = compound_identity ( s, depth ) ;
if ( !IS_NULL_ptr ( s ) ) {
return ( compound_type ( tag, s, depth + 1 ) ) ;
}
}
return ( NULL_ptr ( TYPE ) ) ;
}
/*
CREATE A COMPOUND TYPE
This routine creates a compound type from the type operation indicated
by tag and the sub-type r. The routine is designed to ensure that
only one copy of each type is created.
*/
TYPE_P compound_type
PROTO_N ( ( tag, r, depth ) )
PROTO_T ( unsigned tag X TYPE_P r X int depth )
{
TYPE s0 ;
TYPE_P s ;
LIST ( TYPE_P ) t = algebra->types ;
/* Search for uses */
while ( !IS_NULL_list ( t ) ) {
s = DEREF_ptr ( HEAD_list ( t ) ) ;
s0 = DEREF_type ( s ) ;
if ( TAG_type ( s0 ) == tag ) {
TYPE_P rr = DEREF_ptr ( type_ptr_etc_sub ( s0 ) ) ;
if ( EQ_ptr ( r, rr ) ) return ( s ) ;
}
t = TAIL_list ( t ) ;
}
s = MAKE_ptr ( SIZE_type ) ;
MAKE_type_ptr_etc ( tag, 0, r, s0 ) ;
COPY_type ( s, s0 ) ;
CONS_ptr ( s, algebra->types, algebra->types ) ;
( void ) compound_identity ( s, depth ) ;
return ( s ) ;
}
/*
CHECK FOR UNDEFINED TYPES
This routine scans the list of all types for any which remain undefined
at the end of the compilation. It also calculates the sizes of all
the defined types.
*/
void check_types
PROTO_Z ()
{
LIST ( TYPE_P ) t = algebra->types ;
while ( !IS_NULL_list ( t ) ) {
TYPE_P s = DEREF_ptr ( HEAD_list ( t ) ) ;
TYPE s0 = DEREF_type ( s ) ;
if ( IS_type_undef ( s0 ) ) {
char *nm = name_type ( s ) ;
error ( ERROR_SERIOUS, "Type %s used but not defined", nm ) ;
} else {
int sz = size_type ( s, 0 ) ;
COPY_int ( type_size ( s0 ), sz ) ;
}
t = TAIL_list ( t ) ;
}
return ;
}
/*
FIND LIST OF DERIVED TYPES
This routine builds up a list of all the types used in the derivation
of t.
*/
static LIST ( TYPE_P ) derived_types
PROTO_N ( ( t, p ) )
PROTO_T ( TYPE_P t X LIST ( TYPE_P ) p )
{
TYPE t0 ;
unsigned tag ;
LIST ( TYPE_P ) q = p ;
while ( !IS_NULL_list ( q ) ) {
TYPE_P s = DEREF_ptr ( HEAD_list ( q ) ) ;
if ( EQ_ptr ( s, t ) ) return ( p ) ;
q = TAIL_list ( q ) ;
}
CONS_ptr ( t, p, p ) ;
t0 = DEREF_type ( t ) ;
tag = TAG_type ( t0 ) ;
switch ( tag ) {
case type_ident_tag : {
/* Identity definition */
IDENTITY_P r = DEREF_ptr ( type_ident_id ( t0 ) ) ;
TYPE_P s = DEREF_ptr ( ident_defn ( r ) ) ;
p = derived_types ( s, p ) ;
break ;
}
case type_structure_tag : {
/* Structure components */
STRUCTURE_P r = DEREF_ptr ( type_structure_struc ( t0 ) ) ;
LIST ( COMPONENT_P ) c = DEREF_list ( str_defn ( r ) ) ;
while ( !IS_NULL_list ( c ) ) {
COMPONENT_P cmp = DEREF_ptr ( HEAD_list ( c ) ) ;
TYPE_P s = DEREF_ptr ( cmp_type ( cmp ) ) ;
p = derived_types ( s, p ) ;
c = TAIL_list ( c ) ;
}
break ;
}
case type_onion_tag : {
/* Union components, fields and maps */
UNION_P r = DEREF_ptr ( type_onion_un ( t0 ) ) ;
LIST ( COMPONENT_P ) c = DEREF_list ( un_s_defn ( r ) ) ;
LIST ( FIELD_P ) f = DEREF_list ( un_u_defn ( r ) ) ;
LIST ( MAP_P ) m = DEREF_list ( un_map ( r ) ) ;
while ( !IS_NULL_list ( c ) ) {
COMPONENT_P cmp = DEREF_ptr ( HEAD_list ( c ) ) ;
TYPE_P s = DEREF_ptr ( cmp_type ( cmp ) ) ;
p = derived_types ( s, p ) ;
c = TAIL_list ( c ) ;
}
while ( !IS_NULL_list ( f ) ) {
FIELD_P fld = DEREF_ptr ( HEAD_list ( f ) ) ;
c = DEREF_list ( fld_defn ( fld ) ) ;
while ( !IS_NULL_list ( c ) ) {
COMPONENT_P cmp = DEREF_ptr ( HEAD_list ( c ) ) ;
TYPE_P s = DEREF_ptr ( cmp_type ( cmp ) ) ;
p = derived_types ( s, p ) ;
c = TAIL_list ( c ) ;
}
f = TAIL_list ( f ) ;
}
while ( !IS_NULL_list ( m ) ) {
MAP_P map = DEREF_ptr ( HEAD_list ( m ) ) ;
LIST ( ARGUMENT_P ) a = DEREF_list ( map_args ( map ) ) ;
TYPE_P s = DEREF_ptr ( map_ret_type ( map ) ) ;
p = derived_types ( s, p ) ;
while ( !IS_NULL_list ( a ) ) {
ARGUMENT_P arg = DEREF_ptr ( HEAD_list ( a ) ) ;
s = DEREF_ptr ( arg_type ( arg ) ) ;
p = derived_types ( s, p ) ;
a = TAIL_list ( a ) ;
}
m = TAIL_list ( m ) ;
}
break ;
}
case type_list_tag :
case type_ptr_tag :
case type_stack_tag :
case type_vec_tag :
case type_vec_ptr_tag : {
/* Pointer subtypes */
TYPE_P s = DEREF_ptr ( type_ptr_etc_sub ( t0 ) ) ;
p = derived_types ( s, p ) ;
break ;
}
}
return ( p ) ;
}
/*
IMPORT A LIST OF TYPES
This routine imports all the types in the list t.
*/
static void import_type_list
PROTO_N ( ( t ) )
PROTO_T ( LIST ( TYPE_P ) t )
{
while ( !IS_NULL_list ( t ) ) {
TYPE_P s = DEREF_ptr ( HEAD_list ( t ) ) ;
TYPE s0 = DEREF_type ( s ) ;
unsigned tag = TAG_type ( s0 ) ;
switch ( tag ) {
case type_primitive_tag : {
PRIMITIVE_P p = DEREF_ptr ( type_primitive_prim ( s0 ) ) ;
CONS_ptr ( p, algebra->primitives, algebra->primitives ) ;
goto register_lab ;
}
case type_ident_tag : {
IDENTITY_P p = DEREF_ptr ( type_ident_id ( s0 ) ) ;
CONS_ptr ( p, algebra->identities, algebra->identities ) ;
goto register_lab ;
}
case type_enumeration_tag : {
ENUM_P p = DEREF_ptr ( type_enumeration_en ( s0 ) ) ;
CONS_ptr ( p, algebra->enumerations, algebra->enumerations ) ;
goto register_lab ;
}
case type_structure_tag : {
STRUCTURE_P p = DEREF_ptr ( type_structure_struc ( s0 ) ) ;
CONS_ptr ( p, algebra->structures, algebra->structures ) ;
goto register_lab ;
}
case type_onion_tag : {
UNION_P p = DEREF_ptr ( type_onion_un ( s0 ) ) ;
CONS_ptr ( p, algebra->unions, algebra->unions ) ;
goto register_lab ;
}
register_lab : {
TYPE_P r = register_type ( s ) ;
if ( !EQ_ptr ( r, s ) ) {
error ( ERROR_SERIOUS,
"Can't import previously used type %s",
name_type ( s ) ) ;
}
break ;
}
default : {
TYPE_P p = DEREF_ptr ( type_ptr_etc_sub ( s0 ) ) ;
( void ) compound_type ( tag, p, 0 ) ;
break ;
}
}
t = TAIL_list ( t ) ;
}
return ;
}
/*
IMPORT A SINGLE ITEM FROM AN ALGEBRA
This routine imports the type named nm from the algebra alg into the
current algebra.
*/
void import_type
PROTO_N ( ( alg, nm ) )
PROTO_T ( char *alg X char *nm )
{
TYPE_P t ;
LIST ( TYPE_P ) p ;
ALGEBRA_DEFN *a = find_algebra ( alg ) ;
if ( a == NULL ) {
error ( ERROR_SERIOUS, "Algebra %s not defined", alg ) ;
return ;
} else if ( a == algebra ) {
error ( ERROR_SERIOUS, "Can't import from current algebra" ) ;
return ;
}
t = find_type ( a, nm ) ;
if ( IS_type_undef ( DEREF_type ( t ) ) ) {
error ( ERROR_SERIOUS, "Type %s::%s not defined", alg, nm ) ;
return ;
}
p = derived_types ( t, NULL_list ( TYPE_P ) ) ;
import_type_list ( p ) ;
while ( !IS_NULL_list ( p ) ) {
DESTROY_CONS_ptr ( destroy_calculus, t, p, p ) ;
UNUSED ( t ) ;
}
return ;
}
/*
IMPORT AN ENTIRE ALGEBRA
This routine imports all the types in the algebra alg into the current
algebra.
*/
void import_algebra
PROTO_N ( ( alg ) )
PROTO_T ( char *alg )
{
ALGEBRA_DEFN *a = find_algebra ( alg ) ;
if ( a == NULL ) {
error ( ERROR_SERIOUS, "Algebra %s not defined", alg ) ;
return ;
} else if ( a == algebra ) {
error ( ERROR_SERIOUS, "Can't import from current algebra" ) ;
return ;
}
import_type_list ( a->types ) ;
return ;
}
/*
FIND THE SIZE OF A TYPE
This routine calculates the size of the type t.
*/
int size_type
PROTO_N ( ( t, depth ) )
PROTO_T ( TYPE_P t X int depth )
{
TYPE t0 = DEREF_type ( t ) ;
int sz = DEREF_int ( type_size ( t0 ) ) ;
if ( sz ) return ( sz ) ;
if ( depth > MAX_TYPE_DEPTH ) {
error ( ERROR_SERIOUS, "Cyclic type definition involving %s",
name_type ( t ) ) ;
return ( 1 ) ;
}
switch ( TAG_type ( t0 ) ) {
case type_ident_tag : {
IDENTITY_P i = DEREF_ptr ( type_ident_id ( t0 ) ) ;
TYPE_P_P s = ident_defn ( i ) ;
sz = size_type ( DEREF_ptr ( s ), depth + 1 ) ;
break ;
}
case type_structure_tag : {
STRUCTURE_P str = DEREF_ptr ( type_structure_struc ( t0 ) ) ;
LIST ( COMPONENT_P ) c = DEREF_list ( str_defn ( str ) ) ;
sz = 0 ;
while ( !IS_NULL_list ( c ) ) {
TYPE_P_P s ;
s = cmp_type ( DEREF_ptr ( HEAD_list ( c ) ) ) ;
sz += size_type ( DEREF_ptr ( s ), depth + 1 ) ;
c = TAIL_list ( c ) ;
}
break ;
}
case type_primitive_tag : sz = SIZE_PRIM ; break ;
case type_enumeration_tag : sz = SIZE_ENUM ; break ;
case type_onion_tag : sz = SIZE_UNION ; break ;
case type_ptr_tag : sz = SIZE_PTR ; break ;
case type_list_tag : sz = SIZE_LIST ; break ;
case type_stack_tag : sz = SIZE_STACK ; break ;
case type_vec_tag : sz = SIZE_VEC ; break ;
case type_vec_ptr_tag : sz = SIZE_VEC_PTR ; break ;
default : {
error ( ERROR_SERIOUS, "Can't take size of type %s",
name_type ( t ) ) ;
sz = 1 ;
break ;
}
}
return ( sz ) ;
}
/*
FIND THE NAME OF A TYPE
This routine finds the long name of the type t.
*/
char *name_type
PROTO_N ( ( t ) )
PROTO_T ( TYPE_P t )
{
CLASS_ID_P id ;
TYPE t0 = DEREF_type ( t ) ;
switch ( TAG_type ( t0 ) ) EXHAUSTIVE {
case type_primitive_tag : {
PRIMITIVE_P a = DEREF_ptr ( type_primitive_prim ( t0 ) ) ;
id = DEREF_ptr ( prim_id ( a ) ) ;
break ;
}
case type_ident_tag : {
IDENTITY_P a = DEREF_ptr ( type_ident_id ( t0 ) ) ;
id = DEREF_ptr ( ident_id ( a ) ) ;
break ;
}
case type_enumeration_tag : {
ENUM_P a = DEREF_ptr ( type_enumeration_en ( t0 ) ) ;
id = DEREF_ptr ( en_id ( a ) ) ;
break ;
}
case type_structure_tag : {
STRUCTURE_P a = DEREF_ptr ( type_structure_struc ( t0 ) ) ;
id = DEREF_ptr ( str_id ( a ) ) ;
break ;
}
case type_onion_tag : {
UNION_P a = DEREF_ptr ( type_onion_un ( t0 ) ) ;
id = DEREF_ptr ( un_id ( a ) ) ;
break ;
}
case type_quote_tag : {
char *a = DEREF_string ( type_quote_defn ( t0 ) ) ;
return ( a ) ;
}
case type_ptr_tag : {
return ( "PTR" ) ;
}
case type_list_tag : {
return ( "LIST" ) ;
}
case type_stack_tag : {
return ( "STACK" ) ;
}
case type_vec_tag : {
return ( "VEC" ) ;
}
case type_vec_ptr_tag : {
return ( "VEC_PTR" ) ;
}
case type_undef_tag : {
char *a = DEREF_string ( type_undef_name ( t0 ) ) ;
return ( a ) ;
}
}
last_id = id ;
return ( DEREF_string ( cid_name ( id ) ) ) ;
}
/*
FIND THE AUXILIARY NAME OF A TYPE
This routine finds the short name of the type t.
*/
char *name_aux_type
PROTO_N ( ( t ) )
PROTO_T ( TYPE_P t )
{
CLASS_ID_P id ;
TYPE t0 = DEREF_type ( t ) ;
switch ( TAG_type ( t0 ) ) EXHAUSTIVE {
case type_primitive_tag : {
PRIMITIVE_P a = DEREF_ptr ( type_primitive_prim ( t0 ) ) ;
id = DEREF_ptr ( prim_id ( a ) ) ;
break ;
}
case type_ident_tag : {
IDENTITY_P a = DEREF_ptr ( type_ident_id ( t0 ) ) ;
return ( name_aux_type ( DEREF_ptr ( ident_defn ( a ) ) ) ) ;
}
case type_enumeration_tag : {
ENUM_P a = DEREF_ptr ( type_enumeration_en ( t0 ) ) ;
id = DEREF_ptr ( en_id ( a ) ) ;
break ;
}
case type_structure_tag : {
STRUCTURE_P a = DEREF_ptr ( type_structure_struc ( t0 ) ) ;
id = DEREF_ptr ( str_id ( a ) ) ;
break ;
}
case type_onion_tag : {
UNION_P a = DEREF_ptr ( type_onion_un ( t0 ) ) ;
id = DEREF_ptr ( un_id ( a ) ) ;
break ;
}
case type_quote_tag : {
char *a = DEREF_string ( type_quote_defn ( t0 ) ) ;
return ( a ) ;
}
case type_ptr_tag : {
return ( "ptr" ) ;
}
case type_list_tag : {
return ( "list" ) ;
}
case type_stack_tag : {
return ( "stack" ) ;
}
case type_vec_tag : {
return ( "vec" ) ;
}
case type_vec_ptr_tag : {
return ( "vec_ptr" ) ;
}
case type_undef_tag : {
char *a = DEREF_string ( type_undef_name ( t0 ) ) ;
return ( a ) ;
}
}
last_id = id ;
return ( DEREF_string ( cid_name_aux ( id ) ) ) ;
}
/*
CHECK FOR COMPLEX TYPES
This routine checks whether a type is complex in the sense that it
requires the statement versions of COPY and DEREF rather than the
expression versions.
*/
int is_complex_type
PROTO_N ( ( t ) )
PROTO_T ( TYPE_P t )
{
TYPE t0 = DEREF_type ( t ) ;
switch ( TAG_type ( t0 ) ) {
case type_structure_tag :
case type_vec_tag :
case type_vec_ptr_tag : {
return ( 1 ) ;
}
case type_ident_tag : {
IDENTITY_P r = DEREF_ptr ( type_ident_id ( t0 ) ) ;
TYPE_P s = DEREF_ptr ( ident_defn ( r ) ) ;
return ( is_complex_type ( s ) ) ;
}
}
return ( 0 ) ;
}