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

#include "analyser.h"

#include "check.h"

#include "high.h"

#include "names.h"

#include "node.h"

#include "read.h"

#include "shape.h"

#include "table.h"

#include "tdf.h"

#include "utility.h"

/*

    ARE MULTIBYTE STRINGS ALLOWED

    This flag is true to indicate that multibyte strings (other than

    8 bits per character) are allowed.

*/

boolean allow_multibyte = 1;

/*

    READ A TOKEN APPLICATION

    A token application of sort s is read and appended to p.

*/

void

read_token(node *p, sortname s)

{

    char *ra;

    char *wtemp;

    sortname rs;

    construct *v;

    tok_info *info;

    boolean in_brackets = 0;

    /* Check bracket (1) */

    read_word();

    if (!func_input && word_type == INPUT_OPEN) {

	in_brackets = 1;

	read_word();

    }

    /* Read token identifier */

    if (word_type != INPUT_WORD) {

	input_error("Token identifier expected");

	return;

    }

    /* Check bracket (2) */

    if (func_input) {

	wtemp = temp_copy(word);

	read_word();

	if (word_type == INPUT_OPEN) {

	    in_brackets = 1;

	} else {

	    looked_ahead = 1;

	}

    } else {

	wtemp = word;

    }

    /* Look up token */

    v = search_var_hash(wtemp, SORT_token);

    if (v == null) {

	input_error("Token %s not declared", wtemp);

	return;

    }

    info = get_tok_info(v);

    rs = info->res;

    ra = info->args;

    if (rs == SORT_unknown) {

	input_error("Token %s not declared", wtemp);

	return;

    }

    if (is_high(rs)) {

	high_sort *h = high_sorts + high_no(rs);

	rs = h->res;

	ra = find_decode_string(h);

    }

    if (rs != s) {

	input_error("Token %s returns %s, not %s", wtemp,

		      sort_name(rs), sort_name(s));

	return;

    }

    adjust_token(v);

    /* Decode arguments */

    p->son = new_node();

    p->son->cons = v;

    if (ra)p->son->son = read_node(ra);

    /* Check end */

    if (in_brackets) {

	read_word();

	if (word_type != INPUT_CLOSE) {

	    is_fatal = 0;

	    input_error("End of token %s construct expected", v->name);

	    looked_ahead = 1;

	}

    } else {

	if (p->son->son) {

	    is_fatal = 0;

	    input_error("Token %s construct should be in brackets",

			  v->name);

	}

    }

    if (do_check)IGNORE set_token_args(info->pars, p->son->son, 0);

    return;

}

/*

    READ A TOKEN NAME

    This routine reads a token name (as opposed to a token application).

    The token should have sort s.

*/

static node *

read_token_name(sortname s)

{

    node *p;

    boolean ok = 0;

    construct *v;

    high_sort *h;

    tok_info *info;

    /* Read token identifier */

    read_word();

    if (word_type != INPUT_WORD) {

	input_error("Token identifier expected");

	return(null);

    }

    /* Look up token */

    v = search_var_hash(word, SORT_token);

    if (v == null) {

	input_error("Token %s not declared", word);

	return(null);

    }

    info = get_tok_info(v);

    /* Check consistency */

    h = high_sorts + high_no(s);

    if (h->res == info->res) {

	if (info->args == null) {

	    if (h->no_args == 0)ok = 1;

	} else if (h->no_args) {

	    char *ha = find_decode_string(h);

	    if (streq(info->args, ha))ok = 1;

	}

    } else if (h->id == info->res) {

	if (info->args == null)ok = 1;

    }

    if (!ok) {

	input_error("Token %s has incorrect sort", v->name);

    }

    /* Return the construct */

    p = new_node();

    p->cons = v;

    if (!text_output) {

	p->son = new_node();

	p->son->cons = &token_cons;

    }

    return(p);

}

/*

    FIND BASIC CONSTRUCT FOR A VARIABLE SORT

    This routine returns the construct for turning an identifier into

    an object of sort s.

*/

static long

make_obj(sortname s)

{

    long mk = -1;

    switch (s) {

	case SORT_al_tag: mk = ENC_make_al_tag; break;

	case SORT_label: mk = ENC_make_label; break;

	case SORT_tag: mk = ENC_make_tag; break;

    }

    return(mk);

}

/*

    IS A VARIABLE SORT A USE OR AN INTRODUCTION?

    This flag is true to indicate that the tag (or whatever) being read

    is a new one being introduced rather than an old one being used.

    The flag intro_tag_var is set to indicate that any tag so introduced

    is a variable.  The flag intro_visible is set to true whenever the

    visible access specifier is read.

*/

static boolean intro_var = 0;

static boolean intro_tag_var = 0;

boolean intro_visible = 0;

/*

    SEARCH FOR A VARIABLE SORT

    This routine initializes, if appropriate, and returns the construct

    corresponding to the object named nm of sort s.

*/

static construct *

search_var_sort(char *nm, sortname s)

{

    construct *v = search_var_hash(nm, s);

    if (intro_var) {

	if (v == null) {

	    v = make_construct(s);

	    v->name = string_copy_aux(nm);

	    /* Don't add to hash table yet */

	    if (s == SORT_tag) {

		tag_info *info = get_tag_info(v);

		info->var = intro_tag_var;

		info->vis = intro_visible;

		intro_visible = 0;

	    }

	} else {

	    input_error("%s %s already in scope", sort_name(s), nm);

	}

    } else {

	if (v == null) {

	    if (!dont_check) {

		is_fatal = 0;

		input_error("%s %s not in scope", sort_name(s), nm);

	    }

	    v = make_construct(s);

	    v->name = string_copy_aux(nm);

	    IGNORE add_to_var_hash(v, s);

	}

    }

    return(v);

}

/*

    READ A VARIABLE SORT

    An identifier representing a construct of sort s is read.

*/

node *

read_var_sort(sortname s)

{

    node *p;

    construct *v;

    read_word();

    if (word_type != INPUT_WORD) {

	input_error("%s identifier expected", sort_name(s));

    }

    v = search_var_sort(word, s);

    p = new_node();

    p->cons = v;

    return(p);

}

/*

    READ A SEQUENCE EXPRESSION

    A sequence expression is read.  This is tricky because it is a list

    of exps followed by an exp, which may be read as a list of exps.

*/

void

read_seq_node(node *p)

{

    node *q = read_node("*[x]?[x]");

    if (q->bro->son) {

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

	q->bro = r;

	p->son = q;

	return;

    }

    q->bro = null;

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

	is_fatal = 0;

	input_error("exp expected");

	return;

    }

   (q->cons->encoding) --;

    p->son = q;

    q = q->son;

    if (q->bro == null) {

	p->son->son = null;

	p->son->bro = q;

    } else {

	while (q->bro->bro)q = q->bro;

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

	q->bro = null;

    }

    return;

}

/*

    READ SORT INDICATED BY A SINGLE DECODE LETTER

    An object with sort given by the decode letter str is read.  If the next

    object is not of this sort then either an error is flagged (if strict

    is true) or null is returned.

*/

static node *

read_node_aux(char *str, int strict)

{

    sortname s;

    char *wtemp;

    node *p, *ps;

    construct *cons;

    read_func fn = null;

    boolean in_brackets = 0;

    /* Find the corresponding sort name */

    if (str[1] == '&') {

	/* Introduced variable */

	intro_var = 1;

	intro_tag_var = 1;

    } else if (str[1] == '^') {

	/* Introduced identity */

	intro_var = 1;

	intro_tag_var = 0;

    }

    switch (str[0]) {

	case 'i': {

	    s = SORT_tdfint;

	    break;

	}

	case 'j': {

	    s = SORT_tdfbool;

	    break;

	}

	case '$': {

	    s = SORT_tdfstring;

	    break;

	}

	case 'F': {

	    s = SORT_unknown;

	    break;

	}

	default : {

	    s = find_sort(str[0]);

	    fn = sort_read[s];

	    break;

	}

    }

    /* Read the next word */

    read_word();

    /* Check for blanks */

    if (word_type == INPUT_BLANK && !strict) {

	word_type = INPUT_BLANK_FIRST;

	return(null);

    }

    /* Check for bars */

    if (word_type == INPUT_BAR && !strict) {

	word_type = INPUT_BAR_FIRST;

	return(null);

    }

    /* Deal with strings */

    if (s == SORT_tdfstring) {

	if (word_type == INPUT_STRING) {

	    p = new_node();

	    p->cons = new_construct();

	    p->cons->sortnum = SORT_tdfstring;

	    p->cons->encoding = word_length;

	    p->cons->name = string_copy(word,(int)word_length);

	    p->cons->next = null;

	    return(p);

	} else {

	    boolean is_multibyte = 0;

	    if (func_input) {

		if (word_type == INPUT_WORD) {

		    if (streq(word, MAKE_STRING)) {

			read_word();

			if (word_type == INPUT_OPEN)is_multibyte = 1;

		    }

		}

	    } else {

		if (word_type == INPUT_OPEN) {

		    read_word();

		    if (word_type == INPUT_WORD) {

			if (streq(word, MAKE_STRING))is_multibyte = 1;

		    }

		}

	    }

	    if (is_multibyte) {

		if (!allow_multibyte) {

		    input_error("Multibyte strings not allowed here");

		}

		p = new_node();

		p->cons = &string_cons;

		p->son = read_node("i*[i]");

		read_word();

		if (word_type != INPUT_CLOSE) {

		    input_error("End of multibyte string expected");

		}

		return(p);

	    }

	}

	if (strict)input_error("String expected");

	return(null);

    }

    /* Deal with numbers */

    if (word_type == INPUT_NUMBER) {

	boolean negate = 0;

	if (*word == '-') {

	    word++;

	    negate = 1;

	}

	p = new_node();

	p->cons = new_construct();

	if (fits_ulong(word, 1)) {

	    p->cons->sortnum = SORT_small_tdfint;

	    p->cons->encoding = (long)octal_to_ulong(word);

	} else {

	    p->cons->sortnum = SORT_tdfint;

	    p->cons->name = string_copy_aux(word);

	}

	switch (s) {

	    case SORT_tdfint: {

		if (negate) {

		    is_fatal = 0;

		    input_error("Negative nat");

		}

		return(p);

	    }

	    case SORT_tdfbool: {

		node *q = new_node();

		q->cons = (negate ? &true_cons : &false_cons);

		q->bro = p;

		return(q);

	    }

	    case SORT_nat: {

		node *q = new_node();

		if (negate) {

		    is_fatal = 0;

		    input_error("Negative nat");

		}

		q->cons = cons_no(SORT_nat, ENC_make_nat);

		q->son = p;

		return(q);

	    }

	    case SORT_signed_nat: {

		node *q = new_node();

		q->cons = cons_no(SORT_signed_nat, ENC_make_signed_nat);

		q->son = new_node();

		q->son->cons = (negate ? &true_cons : &false_cons);

		q->son->bro = p;

		return(q);

	    }

	    default : {

		if (strict)input_error("%s expected", sort_name(s));

		return(null);

	    }

	}

    }

    /* Deal with strings */

    if (word_type == INPUT_STRING) {

	if (s == SORT_string) {

	    node *q;

	    p = new_node();

	    p->cons = new_construct();

	    p->cons->sortnum = SORT_tdfstring;

	    p->cons->encoding = word_length;

	    p->cons->name = string_copy(word,(int)word_length);

	    p->cons->next = null;

	    q = new_node();

	    q->cons = cons_no(SORT_string, ENC_make_string);

	    q->son = p;

	    return(q);

	}

    }

    /* That was the last chance for numbers */

    if (fn == null) {

	if (strict)input_error("Number expected");

	return(null);

    }

    /* Check for brackets (1) */

    if (!func_input && word_type == INPUT_OPEN) {

	in_brackets = 1;

	read_word();

    }

    /* The next word should be the identifier */

    if (word_type != INPUT_WORD) {

	if (strict)input_error("%s expected", sort_name(s));

	return(null);

    }

    /* Check for brackets (2) */

    if (func_input) {

	wtemp = temp_copy(word);

	read_word();

	if (word_type == INPUT_OPEN) {

	    in_brackets = 1;

	} else {

	    looked_ahead = 1;

	}

    } else {

	wtemp = word;

    }

    if (s == SORT_string && streq(word, MAKE_STRING)) {

	node *q;

	p = new_node();

	p->cons = &string_cons;

	p->son = read_node("i*[i]");

	read_word();

	if (word_type != INPUT_CLOSE) {

	    input_error("End of multibyte string expected");

	}

	q = new_node();

	q->cons = cons_no(SORT_string, ENC_make_string);

	q->son = p;

	return(q);

    }

    /* Look up construct */

    cons = search_cons_hash(wtemp, s);

    if (cons) {

	p = fn(cons->encoding);

	ps = p->son;

    } else {

	boolean do_check_tag = 0;

	if (!in_brackets && (s == SORT_al_tag || s == SORT_label ||

			       s == SORT_tag)) {

	    do_check_tag = 1;

	}

	/* Look up token */

	cons = search_var_hash(wtemp, SORT_token);

	if (cons) {

	    tok_info *info = get_tok_info(cons);

	    sortname rs = info->res;

	    char *ra = info->args;

	    if (rs == SORT_unknown) {

		if (do_check_tag)goto check_lab;

		input_error("Token %s not declared", wtemp);

	    }

	    if (is_high(rs)) {

		high_sort *h = high_sorts + high_no(rs);

		rs = h->res;

		ra = find_decode_string(h);

	    }

	    if (rs != s) {

		if (do_check_tag)goto check_lab;

		if (!strict) return(null);

		input_error("Token %s returns %s, not %s", wtemp,

			      sort_name(rs), sort_name(s));

	    }

	    adjust_token(cons);

	    p = new_node();

	    p->cons = cons_no(s, sort_tokens[s]);

	    p->son = new_node();

	    p->son->cons = cons;

	    if (ra)p->son->son = read_node(ra);

	    ps = p->son->son;

	    if (do_check) {

		IGNORE set_token_args(info->pars, p->son->son, 0);

		if (s == SORT_exp)check_exp(p);

	    }

	} else {

	    /* Look up label, tag etc */

	    if (do_check_tag) {

		check_lab : cons = search_var_sort(wtemp, s);

	    }

	    if (cons) {

		long mk = make_obj(s);

		p = new_node();

		p->cons = cons_no(s, mk);

		p->son = new_node();

		p->son->cons = cons;

		ps = null;

	    } else {

		if (strict) {

		    input_error("Illegal %s, %s", sort_name(s), wtemp);

		}

		return(null);

	    }

	}

    }

    /* Check end of construct */

    if (in_brackets) {

	read_word();

	if (word_type != INPUT_CLOSE) {

	    is_fatal = 0;

	    input_error("End of %s construct expected", cons->name);

	    looked_ahead = 1;

	}

    } else {

	if (ps) {

	    is_fatal = 0;

	    input_error("%s construct should be in brackets", cons->name);

	}

    }

    return(p);

}

/*

    BRING VARIABLES INTO AND OUT OF SCOPE

    The tags, labels etc introduced in p are brought into (if end is

    false) or out of (if end is true) scope.  This only works because

    all the constructs which introduce these variables are of a fairly

    simple form.

*/

static void

adjust_scope(node *p, int end)

{

    node *p0 = p;

    while (p) {

	construct *v = p->cons;

	sortname s = v->sortnum;

	switch (s) {

	    case SORT_repeat:

	    case SORT_option: {

		/* Scan repeated and optional arguments */

		if (p->son)adjust_scope(p->son, end);

		break;

	    }

	    case SORT_al_tag:

	    case SORT_label:

	    case SORT_tag: {

		/* Variable found - adjust scope */

		if (v->encoding == make_obj(s)) {

		    construct *u = p->son->cons;

		    if (end) {

			if (s == SORT_tag) {

			    /* Visible tags aren't removed */

			    tag_info *info = get_tag_info(u);

			    if (info->vis)break;

			}

			remove_var_hash(u->name, s);

		    } else {

			if (add_to_var_hash(u, s)) {

			    input_error("%s %s already in scope",

					  sort_name(s), u->name);

			}

			if (do_check && s == SORT_tag) {

			    /* Fill in shape of tag */

			    node *ts;

			    node *p1 = p->bro;

			    tag_info *info = get_tag_info(u);

			    if (p1 && p1->cons->sortnum == SORT_exp) {

				/* identity and variable have "t&x" */

				ts = p1->shape;

			    } else if (p0->cons->sortnum == SORT_shape) {

				/* make_proc etc have "S?[u]t&" */

				ts = copy_node(p0);

			    } else {

				/* don't know about other constructs */

				ts = null;

			    }

			    /* Declaration = ?[u]?[X]S from 4.0 */

			    info->dec = new_node();

			    info->dec->cons = &false_cons;

			    info->dec->bro = new_node();

			    info->dec->bro->cons = &false_cons;

			    info->dec->bro->bro = ts;

			}

		    }

		}

		break;

	    }

	}

	p = p->bro;

    }

    return;

}

/*

    CHECK FOR COMMA OR CLOSE BRACKET

    The next word should be a comma, which is stepped over, or a close

    bracket.

*/

static void

check_comma(void)

{

    read_word();

    if (word_type == INPUT_COMMA) {

	read_word();

	looked_ahead = 1;

	if (word_type == INPUT_CLOSE) {

	    is_fatal = 0;

	    input_error("Badly placed comma");

	}

	return;

    }

    if (word_type != INPUT_CLOSE) {

	is_fatal = 0;

	input_error("Comma or close bracket expected");

    }

    looked_ahead = 1;

    return;

}

/*

    READ SORTS GIVEN BY A STRING OF DECODE LETTERS

    A node corresponding to the decode string str is read from the

    input file.

*/

node *

read_node(char *str)

{

    char c;

    position store;

    node *p, *q = null, *qe = null;

    while (c = *str,(c != 0 && c != ']')) {

	switch (c) {

	    case '{': {

		/* Start of scope */

		adjust_scope(q, 0);

		p = null;

		break;

	    }

	    case '}': {

		/* End of scope */

		adjust_scope(q, 1);

		p = null;

		break;

	    }

	    case '[':

	    case '|':

	    case '&':

	    case '^': {

		/* Ignore these cases */

		p = null;

		break;

	    }

	    case '*':

	    case '!': {

		/* Repeats */

		char cr;

		char *sr;

		long n = 0;

		int opt = 0;

		node *pe = null, *pr;

		str += 2;

		cr = *str;

		sr = str;