Previous Up Next

Second pass
(pass2)

Introduction

This module contains the testing procedures of the first part of the second pass, which are concerned with testing the grammar and calculating the attributes [main 1].

1 Testing classes defined

The procedure test all classes defined checks whether all the class identifiers have a non empty class rule specified. If there is at least one class identifier with an empty class rule, all the class identifiers with an empty class rule are enumerated in the listing.

2 Testing unambiguous classes

The procedure test deterministic checks whether there are no ambiguous class definitions [4.7.1.1]. As a side effect the record field clos class of the element identifiers is calculated. The test is performed by constructing the "clos class" relation [2.6.1] for all the elements. The local procedure test fills the record field clos class for the element with the number equal to the parameter elem nr. The contents is only calculated once, using the local variable done of type elements, which contains the elements that have been calculated. For the class identifiers the value is calculated by taking the union of the clos class record fields of the elements in the record field class rule, after these have been calculated by recursively calling the procedure test. If during this calculation overlapping sets are found, an error message is given for the element for which the clos class record field is being calculated, indicating that there is an element that can be reached in more than one way through the class hierarchy from this element.

3 Testing reachability

The procedure test reachability checks the reachability property of the grammar specified by the rules. The kind of reachability is determined by the parameter kind of type tkind reach.

The test if performed by seeking all the elements that can be reached from the root element. This seeking is done by the local procedure seek. All the elements that are found are stored in the local variable found of type elements. When an element is found with an indirect tree rule the procedure seeks the element with which this tree rule was declared.

The procedure test reachability prints an enumeration of elements that are not reached but had to be reached according to the kind of enumeration, if such elements exist.

4 Testing termination

The procedure test termination checks the termination property of the grammar specified by the rules. The algorithm that is used to test termination is derived from the definition in [2.8.2], whereby the local procedure seek term  is the equivalent of "termination". The algorithm is optimised by storing all the in-between results which are found. The local variable termination contains all the elements that found to be terminating, and the local variable non terminating contains all the elements that found to be non-terminating. These variables are inspected and/or updated each time the procedure seek term is called.

Note the definition of the type tkind term and the two local functions min and max on this type. It turns out that the (non)termination property can be modelled in an elegant way.

The procedure test terminates prints an enumeration of the elements that do not terminate, if there is at least one element that does not terminate.

5 Attributes

The procedure gen all attributes calculates the elements of the record field attr of the element identifiers [1.10.2], and tests the restrictions imposed on these attribute relations [2.104.11]. The local procedure assign all attr calculates the record field attr for the element with the element number equal to the parameter elem nr. This procedure calls itself recursively. The local variable done keeps track of the set of elements for which the attributes are calculated. For each conflict that is found a message is printed on the listing file by the procedure print conflict. This procedure prints a message explaining in which relation the conflicted occurred. This message contains the names of the classes involved, together with the sets of attributes assigned to these classes for the particular relation.

6 Interface

This module uses declarations from the following modules:

6.1 Exported type

The module exports the following type declaration:

6.2 Exported procedures

The following procedures are exported by this module:

This procedure checks whether all the class do have a class definition. See section 1

This procedure checks whether there are no ambiguous class definitions. See section 2

This procedure tests the reachability of kind kind, which can be complete or concrete. See section 3

This procedure tests the termination property of all the elements. See section 4

This procedure calculates the elements of the record field attr of the element identifiers, and tests the restrictions imposed on the attribute relations. See section 5

7 Listing

7.1 Environment and types

[ENVIRONMENT ('pass2.pen'),
 INHERIT ('bintree.pen',
          '[-.screen]openfiles.pen',
          '[-.screen]screen.pen',
          'definitions.pen',
          'listing.pen',
          'trans .pen')]MODULE pass2;

TYPE
  tkind_reach   = (r_comp, r_conc);

7.2 Variable declarations

VAR
(* local for this program                                                     *)
  trans_errors   : integer;    (* number of transformation errors             *)

7.3 Testing all classes defined

  PROCEDURE test_all_classes_defined;
  (* This procedure checks whether all the classes do have a class rule       *)
  (* defined. If not, a message is given on the output and the classes are    *)
  (* printed in the listing file under the heading "UNDEFINED CLASSES".       *)
  VAR
    elem_nr    : integer;
    no_heading : boolean;
  BEGIN
    enter_level('classes defined');
    no_heading := TRUE;
    FOR elem_nr := 0 TO nr_of_elem
    DO WITH element[elem_nr]^
       DO BEGIN
            add_level_info(name);
            IF   (kind = n_class) AND (class_rule = [])
            THEN BEGIN
                   IF   no_heading
                   THEN BEGIN
                          write(listing, 'CLASSES WITHOUT CLASS RULE');
                          print_newline;
                          write(listing, 'for:');
                          print_newline(2);
                          no_heading := FALSE;
                        END
                   ELSE print_alfa(', ');
                   display_error_on_screen('class has no class rule');
                   print_alfa(name)
                 END
          END;
    IF NOT no_heading
    THEN print_newline(3);
    exit_level
  END;

7.4 Deterministic class rules

  PROCEDURE test_deterministic;
  (* This procedure checks whether all the class rules are deterministic.     *)
  (* This means that the closures of the classes of the elements of a class   *)
  (* are disjoint. The test can be described with :                           *)
  (*                                                                          *)
  (*   ALL C IN classes                                                       *)
  (*      (ALL C1,C2 IN (class(C) INTERSECTION classes)                       *)
  (*          ((C1 IS NOT C2)                                                 *)
  (*           IMPLIES (clos_class(C1) DISJOINT clos_class(C2))              *)
  (*          )                                                               *)
  (*      )                                                                   *)
  (*                                                                          *)
  (* In this test the clos_class relation is also made.                       *)
  VAR
    done      : elements;
    no_header : boolean;
    elem_nr   : integer;

    PROCEDURE error_message(class_nr : integer);
    (* This procedure prints an error message with a heading, if this has not  *)
    (* been printed yet, using the variable no_heading.                       *)
    BEGIN
      IF   no_header
      THEN BEGIN
             write(listing, 'NON DETERMINISTIC CLASS RULES');
             print_newline;
             write(listing, 'for:');
             print_newline(2);
             no_header := FALSE
           END
      ELSE print_alfa(', ');
      display_error_on_screen('non_deterministic class rules ');
      print_alfa(element[class_nr]^.name)
    END;

    PROCEDURE test(elem_nr : integer);
    (* This procedure performs the test form the elements with elem_nr.       *)
    VAR
      class  : elements;
      new_nr : integer;
    BEGIN
      enter_level('test  ');
      add_level_info(element[elem_nr]^.name);
      wait(0.5);
      IF   NOT (elem_nr IN done)
      THEN BEGIN
             IF   elem_nr IN node_types
             THEN element[elem_nr]^.clos_class := []
             ELSE (* element is a class, make clos_class relation : *)
                  WITH element[elem_nr]^
                  DO BEGIN
                       clos_class := class_rule;
                       class := class_rule;
                       new_nr := start_nr;
                       WHILE class <> []
                       DO BEGIN
                            next_elem(new_nr, class);
                            test(new_nr);
                            IF   clos_class * element[new_nr]^.clos_class <> []
                            THEN error_message(elem_nr);
                            clos_class :=   clos_class
                                          + element[new_nr]^.clos_class
                          END
                     END;
             done := done + [elem_nr]
           END;
      exit_level
    END;

  BEGIN (* of test_deterministic *)
    enter_level('deterministic');
    done := [];
    no_header := TRUE;
    FOR elem_nr := 0 TO nr_of_elem
    DO test(elem_nr);
    IF   NOT no_header
    THEN print_newline(3);
    exit_level
  END;

7.5 Reachability

  PROCEDURE test_reachability(kind : tkind_reach);
  (* This procedure tests the reachability of kind kind, which can be         *)
  (* complete or concrete. If not so an error message is generated that tells *)
  (* which elements are not reached.                                          *)
  VAR
    found : elements;

    PROCEDURE seek(elem : pnode);
    (* This procedure seeks reachable elements from the reachable element     *)
    (* elem_nr. Because of endless recursion and efficiency the global set    *)
    (* found is inspected and updated.                                        *)
    VAR
      walker  : ptree_rule;
      class   : elements;
      elem_of : integer;
      pparent : boolean;

    BEGIN
      enter_level('seek');
      add_level_info('from : ' + elem^.name);
      wait(0.5);
      WITH elem^
      DO IF   NOT(elem_nr IN found)
         THEN (* not yet sought starting with this element *)
              BEGIN
                found := found + [elem_nr];
                IF   kind_of_rule = r_dire
                THEN (* start seeking from this tree rule *)
                     BEGIN
                       walker := tree_rule;
                       REPEAT
                         seek(walker^.element);
                         walker := walker^.rest
                       UNTIL walker = NIL
                     END
                ELSE IF   kind_of_rule = r_indi
                     THEN (* seek further with parent that imported the rule *)
                          BEGIN
                            elem_of := start_nr;
                            pparent := FALSE;
                            REPEAT
                              elem_of := succ(elem_of);
                              IF   elem_of IN parent
                              THEN pparent := element[elem_of]^.kind_of_rule
                                              IN [r_dire, r_indi]
                            UNTIL pparent;
                            seek(element[elem_of])
                          END;
                class   := class_rule;
                elem_of := start_nr;
                WHILE class <> []
                DO BEGIN
                     next_elem(elem_of, class);
                     seek(element[elem_of])
                   END
              END;
      exit_level
    END;

    PROCEDURE print_message(kind : alfa; missing : elements);
    (* This procedure prints all the elements that do not have the required   *)
    (* reachability. They are printed as a list separated by commas.          *)
    VAR
      elem_nr : integer;
    BEGIN
      IF   missing <> []
      THEN BEGIN
             display_error_on_screen('ERROR: The' + kind +
                                     'reachability is not satisfied', 1.5);
             write(listing, 'THE',kind,'REACHABILITY IS NOT SATISFIED');
             print_newline;
             write(listing, 'for:');
             print_newline(2);
             elem_nr := start_nr;
             REPEAT
               next_elem(elem_nr, missing);
               print_alfa(element[elem_nr]^.name);
               IF   missing <> []
               THEN print_alfa(', ')
             UNTIL missing = [];
             print_newline(3)
           END
    END;

  BEGIN (* of test_reachability *)
    enter_level('reachability');
    found := [];
    seek(root);
    CASE kind OF
      r_comp : print_message(' COMPLETE ', (classes + node_types) - found);
      r_conc : print_message(' CONCRETE ',  node_types - found)
    END;
    exit_level
  END;

7.6 Test termination

  PROCEDURE test_termination;
  (* This procedure tests the termination property of all the elements.       *)
  (* It uses some global sets of elements. The set termination is the set     *)
  (* of all the elements that do have the termination property. The set       *)
  (* non_termination is the set of all the elements that are not terminating. *)
  TYPE
    tkind_term = (t_non_term, t_unknown, t_term);
  VAR
    no_header       : boolean;
    termination     ,
    non_termination : elements;
    elem_nr         : integer;

    PROCEDURE find_term(elem : pnode);
    (* This procedure test whether the element elem_nr, does have the         *)
    (* termination or non_termination property. If it does have the           *)
    (* non_termination property an error message is generated.                *)

      FUNCTION seek_term(elem : pnode; illegal : elements; depth : integer
                        ) : tkind_term;
      (* This function tests whether the element elem_nr terminates, the      *)
      (* elements in the set illegal are assumed not to have the termination  *)
      (* property.                                                            *)
      VAR
        walker  : ptree_rule;
        class   : elements;
        elem_nr ,
        elem_of : integer;
        test    : tkind_term;
        info    : VARYING[50] OF char;

        FUNCTION min(a,b : tkind_term) : tkind_term;
        BEGIN
        IF  a > b
          THEN min := b
          ELSE min := a
        END;

        FUNCTION max(a,b : tkind_term) : tkind_term;
        BEGIN
        IF  a < b
          THEN max := b
          ELSE max := a
        END;

      BEGIN
        enter_level('seek termination');
        info := elem^.name;
        add_level_info(info);
        elem_nr := elem^.elem_nr;
        IF   elem_nr IN termination
        THEN (* this element does already have the termination property *)
             test := t_term
        ELSE
        IF   elem_nr IN non_termination
        THEN (* this element can not have the termination property *)
             test := t_non_term
        ELSE
        IF   elem_nr IN illegal
        THEN (* property is unknown, because of circularity *)
             test := t_unknown
        ELSE (* this element could have the termination property *)
             WITH element[elem_nr]^
             DO BEGIN
                  illegal := illegal + [elem_nr];
                  IF   kind_of_rule = r_empt
                  THEN (* This node type will surely terminate *)
                       test := t_term
                  ELSE
                  IF   tree_rule <> NIL
                  THEN (* this element has a tree rule *)
                       BEGIN
                         test := t_term;
                         walker := tree_rule;
                         WHILE (walker <> NIL) AND (test <> t_non_term)
                         DO BEGIN
                              test := min(test
                                         ,seek_term(walker^.element, illegal,
                                          depth + 3));
                              walker := walker^.rest
                            END
                       END
                  ELSE (* element is class, with a class rule *)
                       BEGIN
                         test := t_non_term;
                         class   := class_rule;
                         elem_of := start_nr;
                         WHILE (class <> []) AND (test <> t_term)
                         DO BEGIN
                              next_elem(elem_of, class);
                              test := max(test,
                                          seek_term(element[elem_of], illegal,
                                                    depth + 3));
                            END
                       END;
                  CASE test OF
                    t_non_term : non_termination := non_termination + [elem_nr];
                    t_term     : termination := termination + [elem_nr];
                    t_unknown  :
                  END
                END;
        CASE test OF
          t_non_term : info := info + ' = NOT TERMINATING';
          t_unknown  : info := info + ' = UNKNOWN';
          t_term     : info := info + ' = TERMINATING'
        END;
        add_level_info(info);
        wait(0.5);
        exit_level;
        seek_term := test
      END;

    BEGIN (* of find_term *)
      IF   seek_term(elem, [], 0) IN [t_non_term, t_unknown]
      THEN BEGIN
             IF   no_header
             THEN BEGIN
                    write(listing, 'TERMINATION IS NOT SATISFIED');
                    print_newline;
                    write(listing, 'for:');
                    print_newline;
                    no_header := FALSE
                  END
             ELSE print_alfa(', ');
             print_alfa(elem^.name);
             display_error_on_screen('ERROR: Termination is not satisfied');
             non_termination := non_termination + [elem^.elem_nr]
           END;
    END;

  BEGIN (* of test_termination *)
    enter_level('test termination');
    no_header := TRUE;
    termination     := [];
    non_termination := [];
    find_term(root);
    FOR elem_nr := 0 TO nr_of_elem
    DO IF   element[elem_nr] <> root
       THEN find_term(element[elem_nr]);
    IF   NOT no_header
    THEN print_newline(3);
    exit_level
  END;

7.7 Attributes

  PROCEDURE gen_all_attributes;
  (* This procedure generates all the functions by filling the attr array of  *)
  (* elements that are in the clos_parents of the node types. The strategy    *)
  (* used is the one that starts from a node type and seeks all attributes of *)
  (* its parent. If they are not generated, when the number is not in the set *)
  (* done, than this is done first. In this way all the attribute functions   *)
  (* are only generated once.                                                 *)
  VAR
    elem_nr   : integer;
    done      : elements;
    no_header : boolean;

    PROCEDURE assign_all_attr(elem_nr : integer);
    (* This procedure generates all the functions for element elem_nr,if they *)
    (* are not yet defined. If they depend on a parent, then a recursive call *)
    (* is made to the parent first.                                           *)
    VAR
      all_attr ,
      par_attr : tattr;
      parents  : elements;
      elem_of  ,
      first_nr : integer;
      first    : boolean;

      PROCEDURE print_error_header;
      (* This procedure prints a header for an error message, at element with *)
      (* number elem_nr.                                                      *)
      BEGIN
        IF   no_header
        THEN BEGIN
               write(listing, 'ATTRIBUTE CONFLICTS OCCURRED');
               no_header := FALSE
             END;
        display_error_on_screen('ERROR: Attribute conflicts occurred');
        print_newline(2);
        print_info('at ' + element[elem_nr]^.name + ' ');
      END;

      PROCEDURE print_attr_set(attrs : attributes; at_pos : integer);
      (* This procedure prints the attribute set attrs, with a left margin    *)
      (* that is shifted at_pos positions.                                    *)
      VAR
        attr_nr : integer;
      BEGIN
        shift_right(at_pos);
        attr_nr := start_nr;
        REPEAT
          next_attr(attr_nr, attrs);
          print_alfa(attribute[attr_nr]^.name);
          IF   attrs <> []
          THEN print_alfa(', ');
        UNTIL attrs = [];
        shift_left(at_pos);
        print_newline
      END;

      PROCEDURE print_message(over : attributes);
      (* This procedure prints a message in case there are overlapping        *)
      (* attributes between element elem_nr and the attributes it gets from   *)
      (* it parent.                                                           *)
      BEGIN
        print_error_header;
        print_alfa('for : ');
        print_attr_set(over,6)
      END;

      PROCEDURE print_conflict(kind : tattr_kind);
      (* this procedure prints that there exists a conflict at element        *)
      (* elem_nr, between the parents first_nr and elem_of, concerning the    *)
      (* kind of attributes that they import at this element.                 *)
      BEGIN
        print_error_header;
        write(listing, 'for ');
        CASE kind OF
          all_gen : write(listing, 'all');
          all_in  : write(listing, 'input');
          all_out : write(listing, 'output');
        END;
        write(listing, ' attributes between the parents :');
        print_newline;
        print_fixed(element[first_nr]^.name, 36); print_alfa(': ');
        print_attr_set(all_attr[kind], 38);
        print_fixed(element[elem_of ]^.name, 36); print_alfa(': ');
        print_attr_set(par_attr[kind], 38);
      END;

    BEGIN (* assign_all_attr *)
      WITH element[elem_nr]^
      DO BEGIN
           enter_level('assign all attr');
           add_level_info(name);
           wait(0.5);
           IF   parent <> []
           THEN (* element is in a class *)
                BEGIN
                  parents := parent;
                  elem_of := start_nr;
                  first   := TRUE;
                  REPEAT
                    next_elem(elem_of, parents);
                    IF   NOT (elem_of IN done)
                    THEN assign_all_attr(elem_of);
                    par_attr := element[elem_of]^.attr;
                    IF   first
                    THEN BEGIN
                           first_nr := elem_of;
                           all_attr := par_attr
                         END
                    ELSE IF   all_attr[all_gen] <> par_attr[all_gen]
                         THEN print_conflict(all_gen)
                         ELSE BEGIN
                                IF   all_attr[all_in ] <> par_attr[all_in ]
                                THEN print_conflict(all_in );
                                IF   all_attr[all_out] <> par_attr[all_out]
                                THEN print_conflict(all_out)
                              END;
                    first := FALSE
                  UNTIL parents = [];
                  IF   (all_attr[all_gen] * attr[nor_gen]) <> []
                  THEN print_message(all_attr[nor_gen] * attr[nor_gen]);
                  attr[all_gen] := attr[nor_gen] + all_attr[all_gen];
                  attr[all_in ] := attr[nor_in ] + all_attr[all_in ];
                  attr[all_out] := attr[nor_out] + all_attr[all_out]
                END
           ELSE BEGIN
                  attr[all_gen] := attr[nor_gen];
                  attr[all_in ] := attr[nor_in ];
                  attr[all_out] := attr[nor_out]
                END
         END;
      done := done + [elem_nr];
      exit_level
    END;

  BEGIN (* of gen_all_attr *)
    enter_level('gen all attributes');
    no_header := TRUE;
    done    := [];
    FOR elem_nr := 0 TO nr_of_elem
    DO IF   NOT (element[elem_nr]^.kind = n_class)
       THEN (* element is a node type *)
            assign_all_attr(elem_nr);
    IF   NOT no_header
    THEN print_newline(3);
    exit_level
  END;

END.


My life as a hacker | My home page