Subversion Repositories tendra.SVN

/*

 * Copyright (c) 2002-2005 The TenDRA Project <http://www.tendra.org/>.

 * All rights reserved.

 *

 * Redistribution and use in source and binary forms, with or without

 * modification, are permitted provided that the following conditions are met:

 *

 * 1. Redistributions of source code must retain the above copyright notice,

 *    this list of conditions and the following disclaimer.

 * 2. Redistributions in binary form must reproduce the above copyright notice,

 *    this list of conditions and the following disclaimer in the documentation

 *    and/or other materials provided with the distribution.

 * 3. Neither the name of The TenDRA Project nor the names of its contributors

 *    may be used to endorse or promote products derived from this software

 *    without specific, prior written permission.

 *

 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS

 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,

 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR

 * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR

 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,

 * EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,

 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;

 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,

 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR

 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF

 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 *

 * $Id$

 */

/*

    		 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(void)

{

    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(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(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(ALGEBRA_DEFN *alg, 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(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(TYPE_P r, 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(unsigned tag, TYPE_P r, 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(void)

{

    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(TYPE_P t, 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(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(char *alg, 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(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(TYPE_P t, 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(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(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(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);

}