Subversion Repositories tendra.SVN

/*

    		 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 "types.h"

#include "alignment.h"

#include "check.h"

#include "eval.h"

#include "node.h"

#include "shape.h"

#include "table.h"

#include "tdf.h"

#include "utility.h"

/*

    BASIC SHAPES

    These shapes are fixed.

*/

node *sh_bottom = null ;

node *sh_proc = null ;

node *sh_top = null ;

/*

    INITIALIZE BASIC SHAPES

    This routine initializes the basic shapes above.

*/

void init_shapes

    PROTO_Z ()

{

    if ( sh_bottom == null ) {

	/* Construct sh_bottom */

	sh_bottom = new_node () ;

	sh_bottom->cons = cons_no ( SORT_shape, ENC_bottom ) ;

	/* Construct sh_proc */

	sh_proc = new_node () ;

	sh_proc->cons = cons_no ( SORT_shape, ENC_proc ) ;

	/* Construct sh_top */

	sh_top = new_node () ;

	sh_top->cons = cons_no ( SORT_shape, ENC_top ) ;

	/* Initialize alignments */

	init_alignments () ;

    }

    return ;

}

/*

    CREATE A NAT CORRESPONDING TO THE LENGTH OF STRING s

    This routine returns a nat giving the length of the string s or the

    null node if this cannot be found.

*/

node *string_length

    PROTO_N ( ( s ) )

    PROTO_T ( node *s )

{

    if ( s->cons->encoding == ENC_make_string ) {

	node *str = s->son ;

	long n = str->cons->encoding ;

	if ( n == -1 ) {

	    str = str->son->bro ;

	    n = str->cons->encoding ;

	}

	return ( make_nat ( n ) ) ;

    }

    return ( null ) ;

}

/*

    COPY A NODE

    This routine makes a copy of the node p.

*/

node *copy_node

    PROTO_N ( ( p ) )

    PROTO_T ( node *p )

{

    node *q ;

    if ( p == null ) return ( null ) ;

    q = new_node () ;

    if ( p->cons->alias ) {

	q->cons = p->cons->alias ;

    } else {

	q->cons = p->cons ;

    }

    q->son = p->son ;

    q->shape = p->shape ;

    return ( q ) ;

}

/*

    FORM AN INTEGER SHAPE

    This routine creates an integer shape from a variety p.

*/

node *sh_integer

    PROTO_N ( ( p ) )

    PROTO_T ( node *p )

{

    node *q = new_node () ;

    q->cons = cons_no ( SORT_shape, ENC_integer ) ;

    q->son = new_node () ;

    if ( p == null ) {

	q->son->cons = &unknown_cons ;

    } else {

	q->son->cons = p->cons ;

	q->son->son = p->son ;

    }

    return ( q ) ;

}

/*

    FORM A FLOATING SHAPE

    This routine creates a floating shape from a floating variety p.

*/

node *sh_floating

    PROTO_N ( ( p ) )

    PROTO_T ( node *p )

{

    node *q = new_node () ;

    q->cons = cons_no ( SORT_shape, ENC_floating ) ;

    q->son = new_node () ;

    if ( p == null ) {

	q->son->cons = &unknown_cons ;

    } else {

	q->son->cons = p->cons ;

	q->son->son = p->son ;

    }

    return ( q ) ;

}

/*

    FORM A POINTER SHAPE

    This routine creates a pointer shape from an alignment p or a shape p.

*/

node *sh_pointer

    PROTO_N ( ( p ) )

    PROTO_T ( node *p )

{

    node *q = new_node () ;

    q->cons = cons_no ( SORT_shape, ENC_pointer ) ;

    q->son = new_node () ;

    p = al_shape ( p ) ;

    if ( p == null ) {

	q->son->cons = &unknown_cons ;

    } else {

	q->son->cons = p->cons ;

	q->son->son = p->son ;

    }

    return ( q ) ;

}

/*

    FORM AN OFFSET SHAPE

    This routine creates an offset shape from the alignments p and q.

*/

node *sh_offset

    PROTO_N ( ( p, q ) )

    PROTO_T ( node *p X node *q )

{

    node *r = new_node () ;

    r->cons = cons_no ( SORT_shape, ENC_offset ) ;

    r->son = new_node () ;

    p = al_shape ( p ) ;

    q = al_shape ( q ) ;

    al_includes ( p, q ) ;

    if ( p == null ) {

	r->son->cons = &unknown_cons ;

    } else {

	r->son->cons = p->cons ;

	r->son->son = p->son ;

    }

    r->son->bro = new_node () ;

    if ( q == null ) {

	r->son->bro->cons = &unknown_cons ;

    } else {

	r->son->bro->cons = q->cons ;

	r->son->bro->son = q->son ;

    }

    return ( r ) ;

}

/*

    FORM AN ARRAY SHAPE

    This routine creates an array shape consisting of n copies of

    the shape p.

*/

node *sh_nof

    PROTO_N ( ( n, p ) )

    PROTO_T ( node *n X node *p )

{

    node *q = new_node () ;

    q->cons = cons_no ( SORT_shape, ENC_nof ) ;

    q->son = new_node () ;

    if ( n == null ) {

	q->son->cons = &unknown_cons ;

    } else {

	q->son->cons = n->cons ;

	q->son->son = n->son ;

    }

    q->son->bro = new_node () ;

    if ( p == null ) {

	q->son->bro->cons = &unknown_cons ;

    } else {

	q->son->bro->cons = p->cons ;

	q->son->bro->son = p->son ;

    }

    return ( q ) ;

}

/*

    FORM A BITFIELD SHAPE

    This routine creates a bitfield shape from a bitfield variety p.

*/

node *sh_bitfield

    PROTO_N ( ( p ) )

    PROTO_T ( node *p )

{

    node *q = new_node () ;

    q->cons = cons_no ( SORT_shape, ENC_bitfield ) ;

    q->son = new_node () ;

    if ( p == null ) {

	q->son->cons = &unknown_cons ;

    } else {

	q->son->cons = p->cons ;

	q->son->son = p->son ;

    }

    return ( q ) ;

}

/*

    FORM A COMPOUND SHAPE

    This routine creates a compound shape from an expression p.

*/

node *sh_compound

    PROTO_N ( ( p ) )

    PROTO_T ( node *p )

{

    node *q = new_node () ;

    q->cons = cons_no ( SORT_shape, ENC_compound ) ;

    q->son = new_node () ;

    if ( p == null ) {

	q->son->cons = &unknown_cons ;

    } else {

	q->son->cons = p->cons ;

	q->son->son = p->son ;

    }

    return ( q ) ;

}

/*

    FIND THE NORMALIZED VERSION OF A SHAPE

    This routine returns the normalized version of the shape p.

*/

node *normalize

    PROTO_N ( ( p ) )

    PROTO_T ( node *p )

{

    if ( p == null ) return ( null ) ;

    if ( p->cons->sortnum == SORT_shape ) {

	switch ( p->cons->encoding ) {

	    case ENC_shape_apply_token : {

		node *q = expand_tok ( p ) ;

		if ( q ) return ( normalize ( q ) ) ;

		break ;

	    }

	    case ENC_offset : {

		node *al1 = al_shape ( p->son ) ;

		node *al2 = al_shape ( p->son->bro ) ;

		return ( sh_offset ( al1, al2 ) ) ;

	    }

	    case ENC_pointer : {

		return ( sh_pointer ( al_shape ( p->son ) ) ) ;

	    }

	}

    }

    return ( copy_node ( p ) ) ;

}

/*

    EXPAND TOKEN APPLICATIONS

    If p is the application of a token it is replaced by the definition

    of that token.  If this is null, null is returned, otherwise the

    expansion continues until p is not a token application.

*/

node *expand_tok

    PROTO_N ( ( p ) )

    PROTO_T ( node *p )

{

    int count = 0 ;

    sortname s = p->cons->sortnum ;

    while ( p->cons->encoding == sort_tokens [s] ) {

	tok_info *info = get_tok_info ( p->son->cons ) ;

	if ( info->def ) {

	    p = info->def ;

	    if ( p->cons->sortnum == SORT_completion ) p = p->son ;

	} else {

	    return ( null ) ;

	}

	if ( ++count > 100 ) return ( null ) ;

    }

    return ( p ) ;

}

/*

    CHECK THAT TWO SHAPES ARE COMPATIBLE

    This routine checks the nodes p and q, which consists of shapes

    or components of shapes, are compatible.  Its action depends on

    the value of tg.  If tg is 0 or 1 then, if the shapes are compatible

    or possible compatible either p or q (whichever is more useful) is

    returned; otherwise an error is reported.  If tg is 2, the routine

    returns sh_bottom if either p or q is the shape bottom, p if p and

    q are definitely compatible, null is they are possible compatible,

    and sh_top if they are definitely not compatible.

*/

node *check_shapes

    PROTO_N ( ( p, q, tg ) )

    PROTO_T ( node *p X node *q X int tg )

{

    sortname s ;

    long np, nq ;

    boolean ok = 1 ;

    node *p0 = ( tg == 2 ? null : p ) ;

    node *q0 = ( tg == 2 ? null : q ) ;

    node *p1 = p ;

    boolean check_further = 0 ;

    /* If one is unknown, return the other */

    if ( p == null ) return ( q0 ) ;

    if ( q == null ) return ( p0 ) ;

    if ( p->cons->sortnum == SORT_unknown ) return ( q0 ) ;

    if ( q->cons->sortnum == SORT_unknown ) return ( p0 ) ;

    s = p->cons->sortnum ;

    np = p->cons->encoding ;

    nq = q->cons->encoding ;

    /* Check for tokens */

    if ( np == sort_tokens [s] ) {

	p = expand_tok ( p ) ;

	if ( p == null ) {

	    if ( np == nq && p1->son->cons == q->son->cons ) {

		if ( p1->son->son == null ) return ( p1 ) ;

	    }

	    return ( q0 ) ;

	}

	np = p->cons->encoding ;

    }

    if ( nq == sort_tokens [s] ) {

	q = expand_tok ( q ) ;

	if ( q == null ) return ( p0 ) ;

	nq = q->cons->encoding ;

    }

    switch ( s ) {

	case SORT_shape : {

	    /* Check for bottoms */

	    if ( tg == 2 ) {

		if ( np == ENC_bottom ) return ( sh_bottom ) ;

		if ( nq == ENC_bottom ) return ( sh_bottom ) ;

	    }

	    /* Don't know about or conditionals */

	    if ( np == ENC_shape_cond ) return ( q0 ) ;

	    if ( nq == ENC_shape_cond ) return ( p0 ) ;

	    if ( np != nq ) {

		ok = 0 ;

	    } else {

		switch ( np ) {

		    case ENC_bitfield :

		    case ENC_floating :

		    case ENC_integer :

		    case ENC_nof : {

			/* Some shapes are inspected closer */

			check_further = 1 ;

			break ;

		    }

		    /* case ENC_pointer */

		    /* case ENC_offset */

		    case ENC_bottom :

		    case ENC_proc :

		    case ENC_top : {

			/* These are definitely compatible */

			if ( tg == 2 ) return ( p1 ) ;

			break ;

		    }

		}

	    }

	    break ;

	}

	case SORT_bitfield_variety : {

	    /* Don't know about conditionals */

	    if ( np == ENC_bfvar_cond ) return ( q0 ) ;

	    if ( nq == ENC_bfvar_cond ) return ( p0 ) ;

	    if ( np != nq ) {

		ok = 0 ;

	    } else {

		/* Simple bitfield varieties are inspected closer */

		if ( np == ENC_bfvar_bits ) check_further = 1 ;

	    }

	    break ;

	}

	case SORT_bool : {

	    /* Don't know about conditionals */

	    if ( np == ENC_bool_cond ) return ( q0 ) ;

	    if ( nq == ENC_bool_cond ) return ( p0 ) ;

	    if ( np != nq ) ok = 0 ;

	    if ( tg == 2 ) return ( ok ? p1 : sh_top ) ;

	    break ;

	}

	case SORT_floating_variety : {

	    /* Don't know about conditionals */

	    if ( np == ENC_flvar_cond ) return ( q0 ) ;

	    if ( nq == ENC_flvar_cond ) return ( p0 ) ;

	    if ( np != nq ) {

		ok = 0 ;

	    } else {

		/* Simple floating varieties are inspected closer */

		if ( np == ENC_flvar_parms ) check_further = 1 ;

	    }

	    break ;

	}

	case SORT_nat : {

	    /* Don't know about conditionals */

	    if ( np == ENC_nat_cond ) return ( q0 ) ;

	    if ( nq == ENC_nat_cond ) return ( p0 ) ;

	    if ( np != nq ) {

		ok = 0 ;

	    } else {

		/* Simple nats are checked */

		if ( np == ENC_make_nat ) {

		    if ( !eq_node ( p->son, q->son ) ) ok = 0 ;

		    if ( tg == 2 ) return ( ok ? p1 : sh_top ) ;

		}

	    }

	    break ;

	}

	case SORT_signed_nat : {

	    /* Don't know about conditionals */

	    if ( np == ENC_signed_nat_cond ) return ( q0 ) ;

	    if ( nq == ENC_signed_nat_cond ) return ( p0 ) ;

	    if ( np != nq ) {

		ok = 0 ;

	    } else {

		/* Simple signed_nats are checked */

		if ( np == ENC_make_signed_nat ) {

		    if ( !eq_node ( p->son, q->son ) ) ok = 0 ;

		    if ( tg == 2 ) return ( ok ? p1 : sh_top ) ;

		}

	    }

	    break ;

	}

	case SORT_variety : {

	    /* Don't know about conditionals */

	    if ( np == ENC_var_cond ) return ( q0 ) ;

	    if ( nq == ENC_var_cond ) return ( p0 ) ;

	    if ( np != nq ) {

		ok = 0 ;

	    } else {

		/* Simple varieties are inspected closer */

		if ( np == ENC_var_limits ) check_further = 1 ;

	    }

	    break ;

	}

	default : {

	    is_fatal = 0 ;

	    input_error ( "Shouldn't be checking %s's", sort_name ( s ) ) ;

	    break ;

	}

    }

    /* Check arguments if necessary */

    if ( check_further ) {

	node *xp = p->son ;

	node *xq = q->son ;

	while ( xp && xq ) {

	    node *c = check_shapes ( xp, xq, tg ) ;

	    if ( tg == 2 ) {

		if ( c == null ) return ( null ) ;

		if ( c == sh_top ) return ( sh_top ) ;

	    }

	    xp = xp->bro ;

	    xq = xq->bro ;

	}

    } else {

	if ( tg == 2 ) return ( null ) ;

    }

    if ( !ok ) {

	/* Definitely not compatible */

	if ( tg == 2 ) return ( sh_top ) ;

	is_fatal = 0 ;

	if ( tg ) {

	    input_error ( "Shape of tag %s does not match declaration",

			  checking ) ;

	} else {

	    input_error ( "Shape incompatibility in %s", checking ) ;

	}

	return ( null ) ;

    }

    return ( p1 ) ;

}

/*

    FIND THE LEAST UPPER BOUND OF TWO SHAPES

    This routine returns the least upper bound of the shapes p and q.

    A return value of null means that the result is unknown.

*/

node *lub

    PROTO_N ( ( p, q ) )

    PROTO_T ( node *p X node *q )

{

    return ( check_shapes ( p, q, 2 ) ) ;

}

/*

    CHECK THAT A SINGLE EXPRESSION HAS THE RIGHT FORM

    The shape of the expression p is checked to be of the form indicated

    by t.  If so (or possibly so) the shape is returned, otherwise an error

    is flagged and null is returned.

*/

node *check1

    PROTO_N ( ( t, p ) )

    PROTO_T ( int t X node *p )

{

    long n ;

    char *nm = p->cons->name ;

    node *s = p->shape, *s0 = s ;

    if ( s == null ) return ( null ) ;

    if ( s->cons->sortnum == SORT_unknown ) return ( s ) ;

    if ( t >= ENC_shape_none ) return ( s ) ;

    n = s->cons->encoding ;

    if ( n == ENC_shape_apply_token ) {

	s = expand_tok ( s ) ;

	if ( s == null ) return ( s0 ) ;

	n = s->cons->encoding ;

    }

    if ( n == ENC_shape_cond ) {

	/* Don't know about conditionals */

    } else if ( n != ( long ) t ) {

	char tbuff [1000] ;

	construct *c = cons_no ( SORT_shape, t ) ;

	if ( p->cons->encoding == ENC_exp_apply_token ) {

	    IGNORE sprintf ( tbuff, "%s (%s)", nm, p->son->cons->name ) ;

	    nm = tbuff ;

	}

	is_fatal = 0 ;

	input_error ( "%s argument to %s should be of %s shape",

		      nm, checking, c->name ) ;

	return ( null ) ;

    }

    return ( normalize ( s ) ) ;

}

/*

    CHECK THAT TWO EXPRESSIONS HAVE THE RIGHT FORM

    The shapes of the expressions p and q are checked to be of the form

    indicated by t and to be compatible.  The shape or null is returned.

*/

node *check2

    PROTO_N ( ( t, p, q ) )

    PROTO_T ( int t X node *p X node *q )

{

    node *sp = check1 ( t, p ) ;

    node *sq = check1 ( t, q ) ;

    if ( t == ENC_nof ) {

	/* For arrays check for concat_nof */

	node *s = null ;

	node *n = null ;

	if ( sp && sq ) {

	    sp = expand_tok ( sp ) ;

	    sq = expand_tok ( sq ) ;

	    if ( sp && sp->cons->encoding == ENC_nof &&

		 sq && sq->cons->encoding == ENC_nof ) {

		/* Find base shape of array */

		s = check_shapes ( sp->son->bro, sq->son->bro, 0 ) ;

		sp = expand_tok ( sp->son ) ;

		sq = expand_tok ( sq->son ) ;

		if ( sp && sp->cons->encoding == ENC_make_nat &&

		     sq && sq->cons->encoding == ENC_make_nat ) {

		    /* Arrays of known size - find concatenated size */

		    construct *np = sp->son->cons ;

		    construct *nq = sp->son->cons ;

		    if ( np->sortnum == SORT_small_tdfint &&

			 nq->sortnum == SORT_small_tdfint ) {

			long up = np->encoding ;

			long uq = nq->encoding ;

			long umax = ( ( long ) 1 ) << 24 ;

			if ( up <= umax && uq <= umax ) {

			    n = make_nat ( up + uq ) ;

			}

		    }

		}

	    }

	}

	return ( sh_nof ( n, s ) ) ;

    }

    return ( check_shapes ( sp, sq, 0 ) ) ;

}

/*

    CHECK THAT A LIST OF EXPRESSIONS HAVE THE RIGHT FORM

    The shapes of the list of expressions given by p are checked to be

    of the form indicated by t and to be compatible.  The shape or

    null is returned.  If nz is true an error is flagged if p is the

    empty list.

*/

node *checkn

    PROTO_N ( ( t, p, nz ) )

    PROTO_T ( int t X node *p X int nz )

{

    node *q, *r ;

    if ( p->cons->encoding == 0 ) {

	if ( nz ) {

	    is_fatal = 0 ;

	    input_error ( "Repeated statement in %s cannot be empty",

			  checking ) ;

	}

	return ( null ) ;

    }

    q = p->son ;

    r = check1 ( t, q ) ;

    while ( q = q->bro, q != null ) {

	node *s = check1 ( t, q ) ;

	r = check_shapes ( r, s, 0 ) ;

    }

    return ( r ) ;

}

/*

    SET TOKEN ARGUMENTS

    This routine assigns the values given by p to the formal token

    arguments given in c.  It is a prelude to expanding token applications.

    Any missing arguments are set to null.  The routine returns the list

    of previous argument values if set is true.

*/

node *set_token_args

    PROTO_N ( ( c, p, set ) )

    PROTO_T ( construct **c X node *p X int set )

{

    node *q = null ;

    node *aq = null ;

    if ( c ) {

	while ( *c ) {

	    tok_info *info = get_tok_info ( *c ) ;

	    if ( set ) {

		node *r = info->def ;

		if ( r ) {

		    r = copy_node ( r ) ;

		    if ( aq == null ) {

			q = r ;

		    } else {

			aq->bro = r ;

		    }

		    aq = r ;

		}

	    }

	    info->def = copy_node ( p ) ;

	    if ( p ) p = p->bro ;

	    c++ ;

	}

    }

    return ( q ) ;

}

/*

    DOES A CONSTRUCT INTRODUCE A TAG OR A LABEL?

    This routine checks whether the construct c introduces a local tag or

    label.

*/

static int is_intro_exp

    PROTO_N ( ( c ) )

    PROTO_T ( construct *c )

{

    if ( c->sortnum == SORT_exp ) {

	switch ( c->encoding ) {

	    case ENC_apply_general_proc :

	    case ENC_conditional :

	    case ENC_identify :

	    case ENC_labelled :

	    case ENC_make_general_proc :

	    case ENC_make_proc :

	    case ENC_repeat :

	    case ENC_variable : {

		return ( 1 ) ;

	    }

	}

    }

    return ( 0 ) ;

}

/*

    DOES A NODE CONTAIN DEFINED TOKENS?

    This routine returns 4 if p is itself an application of a token, 3 if

    it is a make_label construct which introduces a new label (the intro

    flag is used to determine this) or a make_tag construct which introduces

    a new tag, 2 if it is a use of such an introduced label or tag, 1 if

    some subnode returns at least tok, and 0 otherwise.

*/

static int contains_tokens

    PROTO_N ( ( p, intro, tok ) )

    PROTO_T ( node *p X int intro X int tok )

{

    long n ;

    node *q ;

    sortname s ;

    if ( p == null ) return ( 0 ) ;

    s = p->cons->sortnum ;

    n = p->cons->encoding ;

    switch ( s ) {

	case SORT_al_tag : {

	    if ( n == ENC_make_al_tag ) return ( 0 ) ;

	    intro = 0 ;

	    break ;

	}

	case SORT_label : {

	    if ( n == ENC_make_label ) {

		if ( intro ) {

		    p->cons->alias = p->cons ;

		    return ( 3 ) ;

		}

		if ( p->cons->alias ) return ( 2 ) ;

		return ( 0 ) ;

	    }

	    intro = 0 ;

	    break ;

	}

	case SORT_tag : {

	    if ( n == ENC_make_tag ) {

		if ( intro ) {

		    p->cons->alias = p->cons ;

		    return ( 3 ) ;

		}

		if ( p->cons->alias ) return ( 2 ) ;

		return ( 0 ) ;

	    }

	    intro = 0 ;

	    break ;

	}

	case SORT_token : {

	    if ( n == ENC_make_tok ) return ( 0 ) ;

	    intro = 0 ;

	    break ;

	}

	case SORT_exp : {

	    intro = is_intro_exp ( p->cons ) ;

	    break ;

	}

	default : {

	    if ( s > 0 ) intro = 0 ;

	    break ;

	}

    }

    if ( p->cons == &shape_of ) {

	tok_info *info = get_tok_info ( p->son->cons ) ;

	q = info->def ;

	if ( q && q->cons->sortnum == SORT_completion ) q = q->son ;

	if ( q && q->shape ) return ( 4 ) ;

	p = p->son ;

    }

    if ( s > 0 && n == sort_tokens [s] ) {

	tok_info *info = get_tok_info ( p->son->cons ) ;

	q = info->def ;

	if ( q ) return ( 4 ) ;

	p = p->son ;

    }

    for ( q = p->son ; q ; q = q->bro ) {

	int c = contains_tokens ( q, intro, tok ) ;

	if ( c == 1 || c >= tok ) return ( 1 ) ;

    }