|
|
This module contains the procedure that transforms the attribute assignments and performs the remaining semantical checks of the attribute assignments and expressions.
The main reason for the transformation is to check whether all attributes are correctly defined by means of the attribute assignments. To check this we need to collect data about which parts of the attribute assignments assign a value to each of the attributes associated with the classes and with the part names. This requires a tree structure [bintree 1.6] which describes the classes and the attributes which belong to each of the part names (including the main part name) of a tree rule. This tree structure is used to store the expressions attached to each of the attributes with the classes, so that they can be easily found in the code generation pass.
The procedure transform makes the transformed attribute assignments of the attribute assignments of all the elements. The procedure transform calls the procedures gen empty tree, tr lattr ass and test complete successively for each element which has a tree rule. These procedures are described in the following subsections.
In the parameter trans errors the number of errors found during the transformation process is returned. The second parameter with tracing has currently no effect at all.
The procedure gen empty tree generates the empty structures for the transformed attribute assignments with the tree rule of an element. This procedure has three parameters. The first parameter elem ptr of type pnode points to the element for which the empty transformed attribute trees have to be generated. In the second (reference) parameter where of type twhere (see section 3), an array is returned that for each part name number, points to the root of the empty tree of this part of the tree rule. In the third (reference) parameter partlist of type tpartlist (see section 3), an array is returned that, for each part name number points to the element attached to that part name, and in which the main part name number points to the element elem ptr. As a side effect the global variable partnames (see section 4) is filled with the part names of the tree rule with the element elem ptr.
For each part of the tree rule the procedure gen tree is called which generates the empty tree starting with an element. It has three parameters. In the first parameter into of type ttr ass [bintree 1.6] an empty transformed assignment tree is returned, starting from the element pointed by the second parameter elem ptr. The third parameter top level indicates whether this procedure was called by gen empty tree or recursively by itself. In the first case it has the value TRUE, otherwise the value FALSE. The value is used to determine the set of attributes that have to be assigned at the top level.
The procedure tr lattr ass transforms the attribute assignments of an element with a tree rule. It has three parameters. The first parameter lattr ass ptr of type plattr ass [bintree 1.5] points to the list of attribute assignments that have to be transformed. The parameters where and partlist represent information about where in the transformed attribute assignments the assignments have to be put in. This procedure calls the procedure tr attr ass for each attribute assignment in the list pointed to by lattr ass ptr.
Incomplete parts of the assignments read by the scanning and parsing pass, (for which error messages were generated) cannot be processed by the second pass. Whenever incomplete parts are encountered, during the transformation process and testing of the expressions, warnings are generated.
The procedure tr attr ass transforms one attribute assignment. It has four parameters. The first parameter attr ass ptr points to the assignment to be transformed. The second parameter where points to the top of the transformed assignments in which the assignment is placed. The third parameter partlist contains the part list which describes the context of the assignment. The fourth parameter gpartnamenr contains the part name number of the part name to which the assignment is made. In selective assignments all assignments have to be made on the part name of the selective assignment on the top level, see [2.11.4]. To prevent errors, the part name number of this part name is passed on.
This procedure either calls the procedure tr simp ass, in the case the assignment is a simple attribute assignment, or the procedure tr sel ass, if the assignment is a selective assignment.
The procedure tr simp ass tries to insert the simple attribute assignment in the transformed attribute assignments by using the local procedure insert in. An error message is generated when the attribute of the simple attribute assignment is not an assignable attribute in the current context. The expression in the simple assignment is tested by calling the procedure test expr, as described in section 2
The procedure insert in uses the value of the parameter attr nr and the set of attributes as represented by the parameter attrs, to insert the expression (as pointed to by the parameter expr ptr) in the list of expressions (as pointed to by the parameter walker), in the correct place. An error message is generated when this place was not equal to NIL, indicating that there is more than one attribute assignment rule for this assigned attribute.
The procedure tr sel ass processes a selective assignment. The procedure tests whether the selective assignment is applied to a class. An error message is generated if this is not true, otherwise the procedure tr alter is called for each alternative of the selective assignment.
The procedure tr alter processes one alternative of a selective assignment. It checks whether the elements of the selector (in the parameter selectors) are elements of the applied class (by using the set of elements in the parameter class). If an element of the selector is not in the applied class, an error message is generated. Otherwise the alternative is processed further, which is done by updating the context, as stored in new where (by calling the procedure update walker) and partlist, before the procedure tr lattr ass in sel is called with the new context.
The procedure tr lattr ass in sel calls the procedure tr attr ass recursively for each attribute statement in the list pointed to by the parameter lattr ass ptr.
The procedure test complete is used to test whether all attributes that have to be assigned are assigned. The parameter test elem ptr points to the element whose transformed attribute assignments have to be tested. It calls the procedure test tree for all the transformed attribute assignments with the tree rule of the element test elem ptr.
The procedure test tree calls the procedure test attr, which tests whether the attributes on the root of the transformed assignment tree, as pointed to by the parameter from, are all assigned. The procedure test attr generates an error message (using the procedure print message) for each empty place found in the list of expressions as pointed to by the parameter lexpr ptr. The procedure test tree calls itself recursively through the procedure test class, for all more deeply nested parts of the transformed assignments tree.
During the testing of expressions warnings are generated for all parts that are incomplete and could not be tested further.
An expression is tested by calling the procedure test expr. The first parameter expr ptr points to the expression to be tested, and the other parameter partlist describes the context of the expression. Depending on the kind of expression one of the following procedures is called: test simple expr, test sem func or test case expr. These functions are described in the following subsections.
To test a simple expression, consisting of an attribute occurrence, the procedure test simple expr is called. The parameter elem points to the element with which the attribute should be associated. If the attribute is not an applied attribute of the element elem, or one of its (grand)parents, an error message is generated.
To test a semantic function expression the procedure test sem func is called. The parameter args points to the list of argument expressions. The procedure calls the procedure test expr recursively for each argument in the list of argument expressions.
To test a case expression the procedure test case expr is called. The first parameter elem points to the element to which the case selection is applied to. If this element is not a class, an error message is generated. The second parameter partnamenr contains the number of the part name of the case expression. The third parameter partlist contains the part list that will be updated in the local procedure test alter.
For each alternative the procedure test alter is called. If all elements in the class are not used in the selectors an error message is generated. The local variable done contains the elements processed by the procedure test alter.
The procedure test alter tests an alternative of a case expression. The first parameter selectors represents the selector of the alternative. The second parameter expr points to the expression of the alternative. The third parameter line nr contains the line number where this alternative was found in the input, and is used for generating error messages.
For each element in the selector that is not in the class of the element with the case expression an error message is generated. For all other elements the procedure test expr is called recursively, with an updated context, as represented by partlist. If an empty selector was found a warning is generated.
This module introduces a number of local types. The type twhere represents a mapping from part names to transformed attribute assignments. It is used during the transformation of the attribute assignments (see section 1.2) to insert the assignments in the right part. This type is declared by:
twhere = ARRAY[0..max_part_nr] OF ttr_ass;
The numbers of the part names are used as index type. The type ttr ass is described in [bintree 1.6].
The type tpartlist represents a mapping from part names to elements, and is used to implement the part list mechanism as introduced in [2.11.2]. It is declared by:
tpartlist = ARRAY[0..max_part_nr] OF pnode;
The numbers of the part names are used as index type. The type pnode is used as a pointer to elements, and is described in [bintree 1.1, 1.10.2].
The type tnesting is used in the procedure test complete for generating error messages. It is used to keep track of the current nesting. This type is declared by:
tnesting = ARRAY[0..max_nesting] OF pnode;
The global variable partnames is used to convert part name numbers into their representation. This is required for adding information in the level stack, as displayed on the screen [screen]. The variable is filled by the procedure gen empty tree (see subsection 1.1), and used by the procedures described in sections 1.2 and 2
This module uses declarations from the following modules:
[ENVIRONMENT ('trans .pen'),
definitions, perform, bintree, screen, listing.
This module only exports the following procedure:
PROCEDURE transform(VAR trans_errors : integer;
with_tracing : boolean);
This procedure transforms the attribute assignments. The number of errors found during the transformation is returned in the parameter trans errors. The parameter with tracing indicates whether tracing is desired or not. See section 1
[ENVIRONMENT ('trans .pen'),
INHERIT ('definitions.pen',
'perform.pen',
'bintree.pen',
'[-.screen]screen.pen',
'listing.pen')]MODULE trans(output);
(* MODULE: TRANS *)
(* This module performs the transformation process within the second pass. *)
(* The main aim of this transformation, is to put the attribute assignments *)
(* in a normalized structure, so that they can be used later. *)
(* During this process the visibility of the attributes is tested as described*)
(* in section 3.9.2, and the consistency as described in section 3.9.2 of *)
(* the article 'Een attribute evaluator generator' *)
(* CONSTANT AND TYPE DECLARATIONS *)
[HIDDEN]
CONST
max_nesting = 10;
[HIDDEN]
TYPE
(* Begin of the declarations for the partlist *)
twhere = ARRAY[0..max_part_nr] OF ttr_ass;
tpartlist = ARRAY[0..max_part_nr] OF pnode;
(* Begin of the declaration for the complete test *)
tnesting = ARRAY[0..max_nesting] OF pnode;
(* For errors : *)
err_line = VARYING[80] OF char;
VAR
partnames : ARRAY[0..max_part_nr] OF alfa;
[HIDDEN]
FUNCTION num4(nr:integer):alfa;
VAR
res : alfa;
BEGIN
writev(res,nr:3,' | ');
num4 := res
END;
[HIDDEN]
FUNCTION partname(nr : integer) : alfa;
BEGIN
IF nr = error_part_nr
THEN partname := '<UNDEFINED>'
ELSE IF (0 > nr) OR (nr > max_part_nr)
THEN partname := '<********>'
ELSE partname := partnames[nr]
END;
[HIDDEN]
FUNCTION attrname(attr : pnode) : alfa;
BEGIN
IF attr = NIL
THEN attrname := '<UNDEFINED>'
ELSE attrname := attr^.name
END;
|
(* The procedures on this page are for testing the consistency of the *)
(* attribute assignments. At the same time the assignments are transformed *)
(* in a more logical form. *)
PROCEDURE transform(VAR trans_errors : integer; with_tracing : boolean);
(* This procedure transforms the attribute assignments in a more logical *)
(* form. While doing this it tests the visibility described in 3.9.2 and *)
(* the consistency, that is that all the attributes that have to be *)
(* assigned, are assigned exactly once, as described in 3.9.3. *)
(* With every partname in a tree rule we can make a tree consisting of *)
(* elements, so that all the sons of a are node equal to the elements with *)
(* the class rule at this element. At every element in this tree we can *)
(* associate a number of attributes that have to be assigned. *)
(* This procedure first generates an empty tree for a tree rule at an *)
(* element, then the attribute assignments are read and the expressions are *)
(* put in the tree at the right places. If two expressions can be put at *)
(* the same place, an error message is generated. At last it is tested *)
(* whether all the places do have an expression. Otherwise an error message *)
(* is generated for every empty place. *)
VAR
elem_nr : integer;
elem_ptr : pnode;
no_top_header : boolean;
where : twhere;
partlist : tpartlist;
|
PROCEDURE print_top_header;
(* This procedure prints a top header for the current element that is *)
(* being transformed, if it is needed, because of an error message. *)
BEGIN
trans_errors := succ(trans_errors);
IF no_top_header
THEN BEGIN
write(listing,'Error messages in the attribute assignments of : ');
print_alfa(elem_ptr^.name);
print_newline(2);
no_top_header := FALSE
END;
END;
PROCEDURE e_attr_not_visible(line_nr : integer; attr : pnode);
(* This procedure prints the message that the attribute with attr, in *)
(* line line_nr is not visible in its context. *)
VAR
err_mess : err_line;
BEGIN
print_top_header;
writev(err_mess, line_nr: 3, ' ERROR : attribute ',
attr^.name, ' not visible in this context');
write(listing, err_mess);
print_newline;
display_error_on_screen(err_mess);
END;
PROCEDURE e_elem_not_in_class(line_nr, elem_nr : integer; elem : pnode);
(* This procedure prints the error message that the element with the *)
(* number elem_nr, is not an element of the class, pointed to by elem. *)
VAR
err_mess : err_line;
BEGIN
print_top_header;
writev(err_mess, line_nr:3, ' ERROR : element ', element[elem_nr]^.name,
' not element of current class ', elem^.name);
write(listing, err_mess);
print_newline;
display_error_on_screen(err_mess);
END;
PROCEDURE w_empty_sel(line_nr : integer);
(* This procedure prints the error message for an empty selector. *)
VAR
err_mess : err_line;
BEGIN
print_top_header;
writev(err_mess, line_nr:3,' WARNING : empty selector');
write(listing, err_mess);
print_newline;
display_error_on_screen(err_mess)
END;
PROCEDURE e_elem_is_not_class(line_nr : integer; elem : pnode);
(* This procedure prints the error message that elem is not a class. *)
VAR
err_mess : err_line;
BEGIN
print_top_header;
writev(err_mess, line_nr:3,' ERROR : element ', elem^.name,
' is not a class');
write(listing, err_mess);
print_newline;
display_error_on_screen(err_mess);
END;
PROCEDURE e_class_not_used(line_nr : integer; elem : pnode);
(* This procedure prints the error message that not all elements in the *)
(* class with this selective construction are used as a selector. *)
VAR
err_mess : err_line;
BEGIN
print_top_header;
writev(err_mess, line_nr:3, ' ERROR : not all elements of class ',
elem^.name, ' are used');
write(listing, err_mess);
print_newline;
display_error_on_screen(err_mess)
END;
PROCEDURE w_surpressed(line_nr : integer);
(* This procedure prints the warning that testing is suppressed, because *)
(* of an unknown partname or attribute. *)
VAR
err_mess : err_line;
BEGIN
print_top_header;
writev(err_mess, line_nr:3,' WARNING : testing is suppressed for ',
'unknown partname or attribute');
write(listing, err_mess);
print_newline;
display_error_on_screen(err_mess);
END;
PROCEDURE w_unrec_expression;
(* This procedure prints the warning that testing is suppressed, because *)
(* of unrecognizable expression. *)
VAR
err_mess : err_line;
BEGIN
print_top_header;
writev(err_mess, '??? WARNING : testing is suppressed for ',
'unrecognizable expression');
print_newline;
display_error_on_screen(err_mess)
END;
PROCEDURE e_double_ass(line_nr, attr_nr, prev_nr : integer);
(* This procedure prints the error message that attribute, with the *)
(* number is assigned before in line number prev_nr. *)
VAR
err_mess : err_line;
BEGIN
print_top_header;
writev(err_mess, line_nr:3, ' ERROR : attribute ',
attribute[attr_nr]^.name,
' assigned before in line ', prev_nr:3);
write(listing, err_mess);
print_newline;
display_error_on_screen(err_mess)
END;
PROCEDURE w_empty_other_sel(line_nr : integer);
(* This procedure prints the warning that the others-selector is empty. *)
VAR
err_mess : err_line;
BEGIN
print_top_header;
writev(err_mess, line_nr:3,' WARNING : empty OTHERS-selector');
write(listing, err_mess);
print_newline;
display_error_on_screen(err_mess)
END;
|
PROCEDURE gen_empty_tree(elem_ptr : pnode;
VAR where : twhere; VAR partlist : tpartlist);
(* This procedure generates the empty trees for element with elemnr. Where *)
(* will held the pointers to the generated trees, which are connected with *)
(* the tree rule of the element. Partlist will held the numbers of the *)
(* corresponding numbers with partnames. *)
VAR
partnamenr : integer;
attr_at_partname : attributes;
walker : ptree_rule;
PROCEDURE gen_tree(VAR into:ttr_ass; elem_ptr:pnode; top_level : boolean);
(* This procedure generates one empty tree starting with the element *)
(* elemnr, and returns the result in in. Top_level is used to determine *)
(* whether we are on the top level of the tree. This is because also *)
(* attributes from the parents should be assigned on the top level. *)
FUNCTION gen_attr(attr_nr : integer; attrs : attributes) : plexpr;
(* This function returns a list of still empty expressions, with a *)
(* length equal to the number of attributes in attrs. attr_nr is used *)
(* to search the set of attrs. *)
VAR
chain : plexpr;
BEGIN
IF attrs = []
THEN gen_attr := NIL
ELSE BEGIN
(* attr_nr := FIRST attrs *)
next_attr(attr_nr, attrs);
new(chain);
WITH chain^
DO BEGIN
first := NIL;
rest := gen_attr(attr_nr, attrs)
END;
gen_attr := chain
END
END;
FUNCTION gen_class(elem_nr : integer; list : elements) : pltr_ass;
(* This function generates a list of child nodes, with the set of *)
(* elements; list. elem_nr is used to search the set of elements list. *)
VAR
chain : pltr_ass;
BEGIN
IF list = []
THEN gen_class := NIL
ELSE BEGIN
(* elem_nr := FIRST list *)
next_elem(elem_nr, list);
new(chain);
WITH chain^
DO BEGIN
gen_tree(first, element[elem_nr], FALSE);
rest := gen_class(elem_nr, list)
END;
gen_class := chain
END;
END;
FUNCTION must_assigned_attr : attributes;
(* This function returns the set of attributes that should be assigned *)
(* with the element, with number elem_nr, and on the level, determined *)
(* with top_level. This procedure uses the global attribute set *)
(* attr_at_partname, which is equal to g_inh_attr, if the current *)
(* partname is the main partname, otherwise equal to g_syn_attr. *)
VAR
attr_kind : tattr_kind;
BEGIN
IF top_level
THEN attr_kind := all_gen
ELSE attr_kind := nor_gen;
WITH elem_ptr^
DO must_assigned_attr
:= (attr[attr_kind] - attr[all_in]) * attr_at_partname
END;
BEGIN (* of gen_tree *)
enter_level('gen tree');
WITH elem_ptr^, into
DO BEGIN
add_level_info(name);
ass_attr := must_assigned_attr;
top := gen_attr(start_nr, ass_attr);
deeper := gen_class(start_nr, class_rule)
END;
wait(0.2);
exit_level
END;
BEGIN (* of gen_empty_tree *)
(* FOR father node DO *)
enter_level('gen empty tree');
partnamenr := 0;
attr_at_partname := g_syn_attr;
WITH elem_ptr^
DO BEGIN
(* generate empty tree and initialize where and partlist *)
gen_tree(trans_ass, elem_ptr, TRUE);
where [partnamenr] := trans_ass;
partlist[partnamenr] := elem_ptr;
(* for tracing : *)
partnames[partnamenr] := '#';
walker := tree_rule
END;
(* FOR ALL tree_rule_elements IN tree_rule DO *)
attr_at_partname := g_inh_attr;
WHILE walker <> NIL
DO BEGIN
partnamenr := succ(partnamenr);
WITH walker^
DO BEGIN
(* generate empty tree and initialize where and partlist *)
gen_tree(trans_ass, element, TRUE);
where [partnamenr] := trans_ass;
partlist[partnamenr] := element;
(* for tracing: *)
partnames[partnamenr] := partname
END;
walker := walker^.rest
END;
exit_level
END;
|
PROCEDURE test_expr(expr_ptr : pexpr; VAR partlist : tpartlist);
(* This procedure tests the visibility as described by test_visibility_EXPR *)
(* with EXPR, pointed by expr_ptr, and partlist partlist. *)
PROCEDURE test_simple_expr(elem : pnode);
(* This procedure tests whether the attribute of this simple expression, *)
(* pointed by expr_ptr is visible from element elem. *)
BEGIN
WITH expr_ptr^
DO IF NOT(attr^.attr_nr IN elem^.attr[all_gen])
THEN e_attr_not_visible(line_nr, attr)
END;
PROCEDURE test_sem_func(args : plexpr);
(* This procedure tests the visibility for the list of expressions, *)
(* pointed to by args and the partlist partlist. *)
BEGIN
WHILE args <> NIL
DO BEGIN
test_expr(args^.first,partlist);
args := args^.rest
END
END;
PROCEDURE test_case_expr(elem : pnode;
partnamenr : integer; partlist : tpartlist);
(* This procedure tests the visibility of a case expression. This *)
(* includes test on the correctness of the used selector, especially that *)
(* elements in the selector must be equal to the elements in the current *)
(* class. Of course the current element at the partnamenr must be a class.*)
VAR
class ,
done : elements;
alt_expr : plalt_expr;
PROCEDURE test_alter(selectors : elements; expr : pexpr;
line_nr : integer);
(* This procedure tests one alternative of the case expression. *)
VAR
elem_nr : integer;
empty_sel : boolean;
BEGIN
enter_level('test alter');
empty_sel := TRUE;
elem_nr := start_nr;
WHILE selectors <> []
DO BEGIN
next_elem(elem_nr, selectors);
add_level_info(num4(line_nr) + element[elem_nr]^.name+' :');
IF elem_nr IN class
THEN BEGIN
done := done + [elem_nr];
empty_sel := FALSE;
partlist[partnamenr] := element[elem_nr];
test_expr(expr, partlist)
END
ELSE e_elem_not_in_class(alt_expr^.line_nr, elem_nr, elem)
END;
IF empty_sel
THEN w_empty_sel(alt_expr^.line_nr);
exit_level
END;
BEGIN (* test_case_expr *)
WITH expr_ptr^
DO BEGIN
IF elem^.kind <> n_class
THEN e_elem_is_not_class(line_nr, elem)
ELSE BEGIN
class := elem^.class_rule;
done := [];
alt_expr := alter;
WHILE alt_expr <> NIL
DO BEGIN
WITH alt_expr^
DO BEGIN
IF other_sel
THEN selectors := selectors * class;
test_alter(selectors, expr, line_nr)
END;
alt_expr := alt_expr^.rest
END;
IF done <> class
THEN e_class_not_used(expr_ptr^.line_nr, elem);
END
END
END;
BEGIN (* of test_expr *)
enter_level('test expr');
IF expr_ptr <> NIL
THEN WITH expr_ptr^
DO CASE kind OF
e_atoc :
BEGIN
add_level_info(num4(line_nr) + attrname(attr)
+ ' OF ' + partname(partnamenr));
IF (partnamenr <> error_part_nr)
AND (attr <> NIL)
THEN test_simple_expr(partlist[partnamenr])
ELSE w_surpressed(line_nr)
END;
e_func :
BEGIN
add_level_info(num4(line_nr) + func^.name);
test_sem_func(args)
END;
e_case :
BEGIN
add_level_info(num4(line_nr) + 'CASE ' + partname(headpnnr)
+ ' OF');
IF headpnnr <> error_part_nr
THEN test_case_expr(partlist[headpnnr],headpnnr,partlist)
ELSE w_surpressed(line_nr)
END
END
ELSE w_unrec_expression;
wait(0.3);
exit_level
END;
|
PROCEDURE tr_lattr_ass(lattr_ass_ptr : plattr_ass;
VAR where : twhere; VAR partlist : tpartlist);
(* This procedure tests and transforms the top attribute assignment list, *)
(* pointed to by lattr_ass_ptr. Where and partlist are used. *)
PROCEDURE tr_attr_ass(attr_ass_ptr : plattr_ass; where : ttr_ass;
VAR partlist : tpartlist; gpartnamenr : integer);
(* This procedure transforms one attribute assignment, pointed to by *)
(* attr_ass_ptr, with the environment described by where and partlist *)
(* at the part with gpartnamenr. *)
PROCEDURE tr_simp_ass;
(* This procedure test the simple attribute assignment pointed by *)
(* lattr_ass_ptr, and inserts it in the right place, which is *)
(* determined by where and gpartname. The expression with this *)
(* assignment is tested test_expr, as defined above. *)
PROCEDURE insert_in(walker : plexpr; attr_nr : integer;
attrs : attributes; expr_ptr : pexpr);
(* This procedure inserts the expression, pointed to by expr_ptr in *)
(* the right place in walker, which is equal to the order of attr_nr *)
(* in the set attrs. If this place is already filled, which means *)
(* there is another attribute assignment on this place, an error *)
(* message is given. *)
VAR
nr : integer;
BEGIN
enter_level('insert in');
nr := start_nr;
next_attr(nr, attrs);
WHILE nr <> attr_nr
DO BEGIN
next_attr(nr, attrs);
walker := walker^.rest
END;
WITH walker^
DO IF first <> NIL
THEN e_double_ass(expr_ptr^.line_nr, attr_nr, first^.line_nr)
ELSE first := expr_ptr;
exit_level
END;
BEGIN (* of tr_simp_ass *)
WITH attr_ass_ptr^, where
DO BEGIN
partnamenr := gpartnamenr;
IF attr <> NIL
THEN IF attr^.attr_nr <> error_nr
THEN IF attr^.attr_nr IN ass_attr
THEN insert_in(top, attr^.attr_nr, ass_attr, expr)
ELSE e_attr_not_visible(line_nr, attr)
ELSE w_surpressed(line_nr)
ELSE w_surpressed(line_nr);
test_expr(expr, partlist)
END
END;
PROCEDURE tr_sel_ass(partlist : tpartlist);
(* This procedure tests and transforms a selective assignment. A new *)
(* partlist is made which can be updated. *)
VAR
class : elements;
alt_ass : plalt_ass;
PROCEDURE tr_alter(selector : elements; lattr_ass_ptr : plattr_ass;
class : elements; line_nr : integer);
(* This procedure tests and transforms one alternative of a selective *)
(* assignment, with the selector selector, and the list of attribute *)
(* assignments, pointed to by lattr_ass_ptr. A new class set is made. *)
VAR
elem_nr : integer;
new_where : ttr_ass;
walker : pltr_ass;
walker_nr : integer;
empty_sel : boolean;
PROCEDURE update_walker(sel_nr : integer; VAR new_where : ttr_ass);
(* This procedure updates new_where with selector element sel_nr. *)
(* It is assumed that sel_nr is in the rest of what is left in the *)
(* set class. because the construction of the remaining list in *)
(* walker depends on what is left in class, they are updated *)
(* simultaneously until the right element number is found. *)
BEGIN
enter_level('update walker');
next_elem(walker_nr, class);
WHILE walker_nr <> sel_nr
DO BEGIN
next_elem(walker_nr, class);
walker := walker^.rest
END;
new_where := walker^.first;
walker := walker^.rest;
wait(0.5);
exit_level
END;
PROCEDURE tr_lattr_ass_in_sel(lattr_ass_ptr : plattr_ass;
where : ttr_ass);
(* This procedure transforms a list of attribute assignments within *)
(* a selective assignment. *)
BEGIN
enter_level('assignment');
WHILE lattr_ass_ptr <> NIL
DO BEGIN
WITH lattr_ass_ptr^
DO CASE kind OF
a_simp : add_level_info(num4(line_nr) + attrname(attr)
+ ' OF ' + partname(gpartnamenr) + ' := ');
a_sele : add_level_info(num4(line_nr) + 'CASE ' +
partname(gpartnamenr) + ' OF ')
END;
tr_attr_ass(lattr_ass_ptr, where, partlist, gpartnamenr);
lattr_ass_ptr := lattr_ass_ptr^.rest
END;
exit_level
END;
BEGIN (* of tr_alter *)
enter_level('tr_alter ');
walker := where.deeper;
walker_nr := start_nr;
empty_sel := TRUE;
elem_nr := start_nr;
WHILE selector <> []
DO BEGIN
next_elem(elem_nr, selector);
IF elem_nr IN class
THEN BEGIN
add_level_info(num4(line_nr) + element[elem_nr]^.name
+ ' : ');
empty_sel := FALSE;
update_walker(elem_nr, new_where);
partlist[gpartnamenr] := element[elem_nr];
tr_lattr_ass_in_sel(lattr_ass_ptr, new_where)
END
ELSE e_elem_not_in_class(lattr_ass_ptr^.line_nr, elem_nr
,partlist[gpartnamenr])
END;
IF empty_sel
THEN w_empty_sel(alt_ass^.line_nr);
exit_level
END;
BEGIN (* of tr_sel_ass *)
WITH attr_ass_ptr^, partlist[gpartnamenr]^
DO IF {partlist[gpartnamenr]^.}kind = n_class
THEN BEGIN
headpnnr := gpartnamenr;
class := class_rule;
alt_ass := alter;
WHILE alt_ass <> NIL
DO BEGIN
WITH alt_ass^
DO BEGIN
IF other_sel
THEN BEGIN
selectors := selectors * class;
IF selectors = []
THEN w_empty_other_sel(line_nr)
ELSE tr_alter(selectors, attr_ass, class,
line_nr)
END
ELSE tr_alter(selectors, attr_ass, class, line_nr)
END;
alt_ass := alt_ass^.rest
END
END
ELSE e_elem_is_not_class(line_nr, partlist[gpartnamenr]);
END;
BEGIN (* of tr_attr_ass *)
CASE attr_ass_ptr^.kind OF
a_simp : tr_simp_ass;
a_sele : tr_sel_ass(partlist)
END;
END;
BEGIN (* of tr_lattr_ass *)
enter_level('assignment');
WHILE lattr_ass_ptr <> NIL
DO BEGIN
WITH lattr_ass_ptr^
DO CASE kind OF
a_simp :
BEGIN
add_level_info(num4(line_nr) + attrname(attr)
+ ' OF ' + partname(partnamenr) + ' := ');
IF partnamenr <> error_part_nr
THEN tr_attr_ass(lattr_ass_ptr, where[partnamenr],
partlist, partnamenr)
ELSE BEGIN
w_surpressed(line_nr);
test_expr(expr, partlist)
END
END;
a_sele :
BEGIN
add_level_info(num4(line_nr) + 'CASE ' +
partname(headpnnr) + ' OF ');
IF headpnnr <> error_part_nr
THEN tr_attr_ass(lattr_ass_ptr, where[headpnnr],
partlist, headpnnr)
ELSE w_surpressed(line_nr)
END
END;
lattr_ass_ptr := lattr_ass_ptr^.rest
END;
exit_level
END;
|
PROCEDURE test_complete(test_elem_ptr : pnode);
(* This procedure tests whether all the attributes that have to be assigned *)
(* in the transformed attribute assignments are assigned. This is done by *)
(* procedures that check the entire transformed tree of empty places. If an *)
(* empty place is found, a trace back till the starting element is made and *)
(* an error message is generated with the information of the attribute. *)
VAR
walker : ptree_rule;
start_partname : alfa;
nesting : tnesting;
no_header : boolean;
PROCEDURE print_message(attr_nr : integer; depth : integer);
(* This procedure prints an error message for an empty place. *)
VAR
d : integer;
BEGIN
IF no_header
THEN BEGIN
print_top_header;
print_newline;
write(listing,'The following attributes are not assigned :');
print_newline(2);
no_header := FALSE
END;
print_alfa(start_partname);
FOR d := 0 TO depth
DO print_alfa('.' + nesting[d]^.name);
print_alfa(': ');
print_alfa(attribute[attr_nr]^.name);
print_newline
END;
PROCEDURE test_tree(from : ttr_ass; elem_ptr : pnode; depth : integer);
(* This procedure tests the transformed attribute assignments, pointed to *)
(* by from, with as current element elem_ptr and current depth. *)
PROCEDURE test_attr(attrs : attributes; lexpr_ptr : plexpr);
(* This procedure tests whether all expressions in the list lexpr_ptr *)
(* are not empty. The set attrs of attributes holds the attributes of *)
(* the list of expressions. *)
VAR
attr_nr : integer;
BEGIN
attr_nr := start_nr;
WHILE lexpr_ptr <> NIL
DO BEGIN
next_attr(attr_nr, attrs);
IF lexpr_ptr^.first = NIL
THEN print_message(attr_nr, depth);
lexpr_ptr := lexpr_ptr^.rest
END
END;
PROCEDURE test_class(list : elements; ltr_ass_ptr : pltr_ass);
(* This procedure tests whether all the attributes for the element in *)
(* class list, starting with the transformed attribute assignment list *)
(* ltr_ass_ptr are assigned. *)
VAR
elem_nr : integer;
BEGIN
depth := succ(depth); (* !!! *)
elem_nr := start_nr;
WHILE ltr_ass_ptr <> NIL
DO BEGIN
next_elem(elem_nr, list);
test_tree(ltr_ass_ptr^.first, element[elem_nr], depth);
ltr_ass_ptr :=ltr_ass_ptr^.rest
END;
END;
BEGIN (* of test_tree *)
enter_level('test tree');
nesting[depth] := elem_ptr;
WITH from
DO BEGIN
test_attr(ass_attr, top);
test_class(elem_ptr^.class_rule, deeper)
END;
exit_level
END;
BEGIN (* of test_complete *)
enter_level('test complete');
no_header := TRUE;
WITH test_elem_ptr^
DO BEGIN
start_partname := main_part_name;
test_tree(trans_ass, test_elem_ptr, 0);
walker := tree_rule
END;
WHILE walker <> NIL
DO BEGIN
WITH walker^
DO BEGIN
start_partname := partname;
test_tree(trans_ass, element, 0)
END;
walker := walker^.rest
END;
exit_level
END;
|
BEGIN
enter_level('transform');
trans_errors := 0;
FOR elem_nr := 0 TO nr_of_elem
DO WITH element[elem_nr]^
DO IF kind_of_rule IN [r_dire, r_empt]
THEN BEGIN
add_level_info(name + ' ');
no_top_header := TRUE;
elem_ptr := element[elem_nr];
perf_start_time(perf_2_e_t);
gen_empty_tree(elem_ptr, where, partlist);
perf_end_time (perf_2_e_t);
perf_start_time(perf_2_trans);
tr_lattr_ass (elem_ptr^.attr_ass, where, partlist);
perf_end_time (perf_2_trans);
perf_start_time(perf_2_t_com);
test_complete (elem_ptr);
perf_end_time (perf_2_t_com);
IF NOT no_top_header
THEN print_newline(3)
END
ELSE WITH trans_ass
DO BEGIN
ass_attr := [];
top := NIL;
deeper := NIL
END;
exit_level
END;
END.
|
My life as a hacker | My home page