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

#include "basic.h"

#include "binding.h"

#include "capsule.h"

#include "file.h"

#include "sort.h"

#include "tree.h"

#include "tdf.h"

#include "unit.h"

#include "utility.h"

/*

    WARN ABOUT UNDECLARED TOKENS

*/

int warn_undeclared = 0;

/*

    DECODING TOKENS

    Simple TOKENs are represented by TDF integers.  They may also be

    tokenised themselves.

*/

object *

de_token_aux(sortname s, char *nm)

{

    word *w;

    long bits, t;

    object *obj = null;

    int ap = 1, simple = 1;

    int just_tok = (s == sort_unknown ? 1 : 0);

    /* Find the token number */

    long n = de_token();

    if (n == token_make_tok) {

	t = tdf_int();

    } else {

	simple = 0;

    }

    /* Look up simple tokens */

    if (simple) {

	SET(t);

	obj = find_binding(crt_binding, var_token, t);

	if (obj == null) {

	    obj = new_object(var_token);

	    set_binding(crt_binding, var_token, t, obj);

	}

	/* Check token sort */

	if (res_sort(obj) == sort_unknown) {

	    sortname is = implicit_sort(obj);

	    if (is == sort_unknown && warn_undeclared) {

		int old_recover = recover;

		int old_exit_status = exit_status;

		recover = 1;

		input_error("Warning : token %s used before it is declared",

			      object_name(var_token, t));

		recover = old_recover;

		exit_status = old_exit_status;

	    }

	    if (is != sort_unknown && is != s) {

		sortid es;

		out("<error>");

		es = find_sort(s);

		input_error("Implicit sort error, token %s, %s expected",

			      object_name(var_token, t), es.name);

	    }

	    implicit_sort(obj) = s;

	} else if (res_sort(obj)!= s && !just_tok) {

	    sortid es;

	    out("<error>");

	    es = find_sort(s);

	    input_error("Sort error, token %s, %s expected",

			  object_name(var_token, t), es.name);

	}

	/* Output token name if appropriate */

	if (!dumb_mode) {

	     if (obj->named) {

		if (obj->name.simple) {

		    out_string(obj->name.val.str);

		    ap = 0;

		}

	    } else {

		char buff[50];

		IGNORE sprintf(buff, "~token_%ld", obj->id);

		out_string(buff);

		ap = 0;

	    }

	}

    }

    /* Output "apply_token" if appropriate */

    if (ap) {

	if (just_tok) {

	    out_string("make_token");

	} else {

	    out_string("apply_");

	    out_string(nm);

	    out_string("_token");

	}

	w = new_word(VERT_BRACKETS);

	if (simple) {

	    SET(t);

	    out_object(t, obj, var_token);

	} else {

	    if (n == token_token_apply_token) {

		object *subobj = de_token_aux(sort_token, "token");

		if (subobj)obj = subobj->aux;

	    } else {

		/* use_tokdef */

		long len = tdf_int();

		skip_bits(len);

		out_string("use_tokdef(....)");

		IGNORE new_word(SIMPLE);

	    }

	}

    } else {

	/* Applications of named tokens are indicated by "*" */

	out_string("*");

    }

    /* Quit here if just reading token */

    if (just_tok) {

	if (ap) {

	    SET(w);

	    end_word(w);

	} else {

	    IGNORE new_word(SIMPLE);

	}

	return(obj);

    }

    /* Read length of token arguments */

    bits = tdf_int();

    /* Deal with tokens without arguments */

    if (bits == 0) {

	if (obj && res_sort(obj)!= sort_unknown) {

	    char *ps = arg_sorts(obj);

	    if (ps && *ps) {

		if (simple) {

		    SET(t);

		    input_error("Token arguments missing, token %s",

				  object_name(var_token, t));

		} else {

		    input_error("Token arguments missing");

		}

	    }

	}

	if (ap) {

	    SET(w);

	    end_word(w);

	} else {

	    IGNORE new_word(SIMPLE);

	}

	return(obj);

    }

    /* Deal with tokens with arguments */

    if (obj && res_sort(obj)!= sort_unknown && !is_foreign(obj)) {

	/* Known token - decode arguments */

	if (arg_sorts(obj)) {

	    long p = posn(here);

	    if (!ap)w = new_word(VERT_BRACKETS);

	    decode(arg_sorts(obj));

	    if (p + bits != posn(here)) {

		if (simple) {

		    SET(t);

		    input_error("Token arguments length wrong, token %s",

				  object_name(var_token, t));

		} else {

		    input_error("Token arguments length wrong");

		}

	    }

	} else {

	    if (ap) {

		SET(w);

		end_word(w);

	    } else {

		IGNORE new_word(SIMPLE);

	    }

	    return(obj);

	}

    } else {

	/* Unknown token - step over arguments */

	if (!ap)w = new_word(VERT_BRACKETS);

	out("....");

	skip_bits(bits);

    }

    SET(w);

    end_word(w);

    return(obj);

}

/*

    DECODING SIMPLE LABELS

*/

void

de_make_label(long lab_no)

{

    if (dumb_mode) {

	word *w;

	out_string("label");

	w = new_word(HORIZ_BRACKETS);

	out_int(lab_no);

	end_word(w);

    } else {

	out_string("~label_");

	out_int(lab_no);

    }

    if (lab_no < 0 || lab_no >= max_lab_no) {

	input_error("Label number %ld out of range", lab_no);

    }

    return;

}

/*

    FORMATTING SIZE FOR TDF STRINGS

    A string will be split by de_format_string into sections of length

    at most STRING_WIDTH.

*/

#define STRING_WIDTH		40

/*

    DECODING FORMATTED STRINGS

    A TDF string is read and output in a formatted form.

*/

void

de_tdfstring_format(void)

{

    string s;

    word *ptr1;

    long sz = tdf_int();

    long n = tdf_int();

    if (sz != 8) {

	char sbuff[100];

	IGNORE sprintf(sbuff, "make_string_%ld", sz);

	out_string(sbuff);

	ptr1 = new_word(HORIZ_BRACKETS);

    }

    if (sz > 8) {

	long i;

	for (i = 0; i < n; i++) {

	    long v = fetch((int)sz);

	    out_int(v);

	}

    } else {

	s = get_string(n, sz);

	n = (long)strlen(s);

	if (n == 0) {

	    out("\"\"");

	    return;

	}

	while (n) {

	    long m = (n < STRING_WIDTH ? n : STRING_WIDTH);

	    char *w = alloc_nof(char, m + 3);

	    IGNORE memcpy(w + 1, s,(size_t)m);

	    w[0] = QUOTE;

	    w[m + 1] = QUOTE;

	    w[m + 2] = 0;

	    out(w);

	    n -= m;

	    s += m;

	}

    }

    if (sz != 8) {

	SET(ptr1);

	end_word(ptr1);

    }

    return;

}

/*

    DECODING THE EXP "solve" (OR "labelled")

    This is tricky because it is encoded as :

		    A1, ..., An, B, C1, ..., Cn

    where n is a TDF integer, Ai is given by the decode string str1,

    B is given by str2, and Ci is given by str3, but we want to print

    it in the order :

		      B, A1, C1, ..., An, Cn

    so there is a certain amount of to-ing and fro-ing.

*/

void

de_solve_fn(char *nm, char *str1, char *str2, char *str3, int ntwice)

{

    long i, n;

    word *ptr1, *ptr2;

    place posn1, posn2;

    int tempflag = printflag;

    out_string(nm);

    ptr1 = new_word(VERT_BRACKETS);

    /* Read the number of statements A1, ..., An */

    check_list();

    n = tdf_int();

    /* Record the position of A1 */

    posn1.byte = here.byte;

    posn1.bit = here.bit;

    /* Step over A1, ..., An */

    printflag = 0;

    for (i = 0; i < n; i++)decode(str1);

    printflag = tempflag;

    /* Decode B */

    decode(str2);

    if (ntwice) {

	/* Read and check the number of statements C1, ..., Cn */

	long m;

	check_list();

	m = tdf_int();

	if (m != n)input_error("Illegal %s construct", nm);

    }

    for (i = 0; i < n; i++) {

	ptr2 = new_word(VERT_BRACKETS);

	/* Record the position of Ci */

	posn2.byte = here.byte;

	posn2.bit = here.bit;

	/* Go back and read Ai */

	set_place(&posn1);

	decode(str1);

	/* Record the position of A(i+1) */

	posn1.byte = here.byte;

	posn1.bit = here.bit;

	/* Go forward and read Ci */

	set_place(&posn2);

	decode(str3);

	end_word(ptr2);

    }

    end_word(ptr1);

    return;

}

/*

    DECODING THE EXP "case"

    Only the layout makes this a special case.  The general form is :

		      A, L1, B1, ..., Ln, Bn

    where A is given by the decode string str1, Li is a label and Bi

    is given by str2.

*/

void

de_case_fn(char *nm, char *str1, char *str2)

{

    long i, n;

    word *ptr1, *ptr2, *ptr3;

    out_string(nm);

    ptr1 = new_word(VERT_BRACKETS);

    decode(str1);

    ptr2 = new_word(VERT_BRACKETS);

    check_list();

    n = tdf_int();

    for (i = 0; i < n; i++) {

	ptr3 = new_word(HORIZ_NONE);

	IGNORE de_label();

	out(":");

	format(HORIZ_BRACKETS, "", str2);

	end_word(ptr3);

    }

    end_word(ptr2);

    end_word(ptr1);

    return;

}

/*

    DECODING THE EXP "make_proc"

    The general form is :

			A, B1, ..., Bn, C

    where A is given by the decode string str1, B by str2 and C by str3.

    However each Bi is grouped as a "make_proc_arg".

*/

void

de_mk_proc_fn(char *nm, char *str1, char *str2, char *str3)

{

    long i, n;

    word *ptr;

    out_string(nm);

    ptr = new_word(VERT_BRACKETS);

    decode(str1);

    check_list();

    n = tdf_int();

    if (n == 0) {

	out("empty");

    } else {

	for (i = 0; i < n; i++) {

	    out_string(nm);

	    format(VERT_BRACKETS, "_arg", str2);

	}

    }

    decode(str3);

    end_word(ptr);

    return;

}