|
|
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].
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.
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.
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.
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.
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.10, 4.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.
This module uses declarations from the following modules:
openfiles, screen, definitions, listing, trans.
The module exports the following type declaration:
tkind_reach = (r_comp, r_conc);
The following procedures are exported by this module:
PROCEDURE test_all_classes_defined;
This procedure checks whether all the class do have a class definition. See section 1
PROCEDURE test_deterministic;
This procedure checks whether there are no ambiguous class definitions. See section 2
PROCEDURE test_reachability(kind : tkind_reach);
This procedure tests the reachability of kind kind, which can be complete or concrete. See section 3
PROCEDURE test_termination;
This procedure tests the termination property of all the elements. See section 4
PROCEDURE gen_all_attributes;
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
[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);
|
VAR (* local for this program *) trans_errors : integer; (* number of transformation errors *) |
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;
|
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;
|
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;
|
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;
|
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