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

{

    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(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(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(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(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(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(node *p, 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(node *n, 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(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(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(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(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(node *p, node *q, 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(node *p, 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(int t, 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(int t, node *p, 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(int t, node *p, 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(construct **c, node *p, 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(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(node *p, int intro, 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) {