/* * Copyright (c) 2002, The Tendra Project * 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/tnc/shape.c,v 1.7 2005/09/21 16:59:15 stefanf Exp $ */ #include "config.h" #include "msgcat.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 : { MSG_shouldnt_be_checking_shape (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); if (tg) { MSG_shape_doesnt_match_declaration (checking); } else { MSG_shape_incompatibility_in (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; } MSG_argument_should_be_of_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) MSG_repeated_statement_cant_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) { p->cons->alias = p->cons; return (3); } if (p->cons->alias) return (2); return (0); } intro = 0; break; } case SORT_tag : { if (n == ENC_make_tag) { if (intro) { p->cons->alias = p->cons; return (3); } if (p->cons->alias) return (2); return (0); } intro = 0; break; } case SORT_token : { if (n == ENC_make_tok) return (0); intro = 0; break; } case SORT_exp : { intro = is_intro_exp (p->cons); break; } default : { if (s > 0) intro = 0; break; } } if (p->cons == &shape_of) { tok_info *info = get_tok_info (p->son->cons); q = info->def; if (q && q->cons->sortnum == SORT_completion) q = q->son; if (q && q->shape) return (4); p = p->son; } if (s > 0 && n == sort_tokens [s]) { tok_info *info = get_tok_info (p->son->cons); q = info->def; if (q) return (4); p = p->son; } for (q = p->son ; q ; q = q->bro) { int c = contains_tokens (q, intro, tok); if (c == 1 || c >= tok) return (1); } return (0); } /* * FULLY EXPAND A NODE * * The node p which has contains_tokens value c (see above) is expanded * recursively. def is true during the expansion of a token definition. */ static node * expand_fully_aux(node *p, int c, int def) { node *q; switch (c) { case 1 : { /* Expand arguments */ node *ap; node *aq = null; int intro = is_intro_exp (p->cons); q = new_node (); q->cons = p->cons; q->shape = p->shape; for (ap = p->son ; ap ; ap = ap->bro) { node *a; c = contains_tokens (ap, intro, 2); a = expand_fully_aux (ap, c, def); if (aq) { aq->bro = a; } else { q->son = a; } aq = a; } break; } case 2 : { /* Tag or label usage */ q = copy_node (p); q->son = copy_node (q->son); break; } case 3 : { /* Tag or label declaration */ p->son->cons->alias = null; if (def) { copy_construct (p->son->cons); q = copy_node (p); q->son = copy_node (q->son); } else { q = copy_node (p); } break; } case 4 : { /* Token application */ construct *tok = p->son->cons; tok_info *info = get_tok_info (tok); q = info->def; if (q) { if (info->depth < 100) { node *prev; info->depth++; if (q->cons->sortnum == SORT_completion) q = q->son; if (p->cons == &shape_of) q = q->shape; prev = set_token_args (info->pars, p->son->son, 1); c = contains_tokens (q, 0, 2); q = expand_fully_aux (q, c, 1); IGNORE set_token_args (info->pars, prev, 0); info->depth--; } else { MSG_nested_expansion_of_token (tok->name); q = copy_node (p); info->depth++; } } else { q = copy_node (p); info->depth++; } break; } default : { /* Simple construct */ q = copy_node (p); break; } } return (q); } /* * EXPAND A SHAPE RECURSIVELY * * All applications of tokens in p are expanded. */ node * expand_fully(node *p) { if (p) { int c = contains_tokens (p, 0, 4); if (c) p = expand_fully_aux (p, c, 0); } return (p); } /* * EXPAND A TOKEN DEFINITION * * This routine expands all the token definitions in the definition of the * token p. */ static void expand_tokdef(construct *p) { if (p->encoding != -1) { tok_info *info = get_tok_info (p); IGNORE set_token_args (info->pars, (node *) null, 0); info->def = expand_fully (info->def); } return; } /* * ELIMINATE A TOKEN DEFINITION * * This routine checks whether p is a local token all of whose uses have * been expanded. If so it eliminates p. */ static void elim_tokdef(construct *p) { if (p->encoding != -1 && p->ename == null) { tok_info *info = get_tok_info (p); if (info->depth == 0) { remove_var_hash (p->name, SORT_token); } } return; } /* * EXPAND AN ALIGNMENT TAG DEFINITION * * This routine expands all the token definitions in the definition of the * alignment tag p. */ static void expand_aldef(construct *p) { if (p->encoding != -1) { al_tag_info *info = get_al_tag_info (p); info->def = expand_fully (info->def); } return; } /* * EXPAND A TAG DECLARATION AND DEFINITION * * This routine expands all the token definitions in the declaration and * definition of the tag p. */ static void expand_tagdef(construct *p) { if (p->encoding != -1) { tag_info *info = get_tag_info (p); info->dec = expand_fully (info->dec); info->def = expand_fully (info->def); } return; } /* * EXPAND ALL TOKEN DEFINITIONS * * This routine expands all defined tokens. */ void expand_all(void) { apply_to_all (expand_tokdef, SORT_token); apply_to_all (expand_aldef, SORT_al_tag); apply_to_all (expand_tagdef, SORT_tag); apply_to_all (elim_tokdef, SORT_token); removals = null; return; }