/*
* Copyright (c) 2002, The Tendra Project <http://www.ten15.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 unmodified, 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.
*
* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
*
*
* 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.
*
* $TenDRA: tendra/src/tools/disp/sort.c,v 1.11 2005/11/05 12:03:15 stefanf Exp $
*/
#include "config.h"
#include "fmm.h"
#include "msgcat.h"
#include "tdf_types.h"
#include "tdf_stream.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"
/*
* WARN ABOUT UNDECLARED TOKENS
*/
BoolT warn_undeclared = FALSE;
/*
* 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) {
MSG_token_used_before_it_is_declared (
object_name (var_token, t));
}
if (is != sort_unknown && is != s) {
sortid es;
out ("<error>");
es = find_sort (s);
MSG_implicit_sort_error (
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);
MSG_sort_error (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 ();
tdf_skip_bits (tdfr, 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);
MSG_token_arguments_missing_token (
object_name (var_token, t));
} else {
MSG_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)) {
tdf_pos pos;
pos = tdf_stream_tell (tdfr);
if (!ap) w = new_word (VERT_BRACKETS);
decode (arg_sorts (obj));
if (tdf_stream_tell(tdfr) != pos + bits) {
if (simple) {
SET (t);
MSG_token_arguments_length_wrong_token (
object_name (var_token, t));
} else {
MSG_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 ("....");
tdf_skip_bits (tdfr, 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) {
MSG_label_number_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)
{
TDFSTRING ts;
word *ptr1;
size_t n;
char *s;
tdf_de_tdfstring(tdfr, &ts);
if (ts.size != 8) {
char sbuff [100];
IGNORE sprintf (sbuff, "make_string_%ld", (long)ts.size);
out_string (sbuff);
ptr1 = new_word (HORIZ_BRACKETS);
}
if (ts.size > 8) {
TDFINTL i;
for (i = 0; i < ts.number; i++)
out_int (ts.ints.longs[i]);
} else {
s = tdf_string_format (&ts);
n = strlen (s);
if (n == 0) {
out ("\"\"");
return;
}
while (n) {
size_t m = (n < STRING_WIDTH ? n : STRING_WIDTH);
char *w = xmalloc_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 (ts.size != 8) {
SET (ptr1);
end_word (ptr1);
}
if (ts.number)
xfree (ts.ints.chars);
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;
tdf_pos 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 = tdf_stream_tell (tdfr);
/* 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) MSG_illegal_construct (nm);
}
for (i = 0; i < n; i++) {
ptr2 = new_word (VERT_BRACKETS);
/* Record the position of Ci */
posn2 = tdf_stream_tell (tdfr);
/* Go back and read Ai */
tdf_stream_seek(tdfr, posn1);
decode (str1);
/* Record the position of A(i+1) */
posn1 = tdf_stream_tell (tdfr);
/* Go forward and read Ci */
tdf_stream_seek(tdfr, 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;
}
syntax highlighted by Code2HTML, v. 0.9.1