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 "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

    PROTO_N ( ( s, nm ) )

    PROTO_T ( sortname s X 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

    PROTO_N ( ( lab_no ) )

    PROTO_T ( 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

    PROTO_Z ()

{

    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

    PROTO_N ( ( nm, str1, str2, str3, ntwice ) )

    PROTO_T ( char *nm X char *str1 X char *str2 X char *str3 X 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

    PROTO_N ( ( nm, str1, str2 ) )

    PROTO_T ( char *nm X char *str1 X 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

    PROTO_N ( ( nm, str1, str2, str3 ) )

    PROTO_T ( char *nm X char *str1 X char *str2 X 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 ;

}