|
|
This module contains a procedure that prints the complete contents of the binary identifier tree in alphabetic order of the identifiers.
The procedure print tree prints the complete binary tree. The global boolean variable with all names controls whether the Pascal identifiers are also printed.
This module uses declarations from the following modules:
definitions, perform, listing, bintree
The following procedure is exported by this module:
PROCEDURE print_tree;
[ENVIRONMENT ('printtree.pen'),
INHERIT ('definitions.pen',
'perform.pen',
'listing.pen',
'bintree.pen')]MODULE printnodetree;
(* MODULE: PRINTTREE *)
(* This program contains the procedures that print the identifier tree and *)
(* related information on the listing. The greatest part concerns the *)
(* printing of attribute assignments. *)
|
[HIDDEN] PROCEDURE print_node(p:pnode);
(* This procedure prints the name of node p, if p equals NIL "<*NIL*>" is *)
(* printed. *)
BEGIN
IF p = NIL
THEN print_alfa('<*NIL*>')
ELSE print_alfa(p^.name)
END;
[HIDDEN] PROCEDURE print_partnamenr(nr:integer);
(* This procedure prints the number of a partname, if the partname is an *)
(* error partname, "<*>" is printed. *)
VAR
scale : integer;
BEGIN
IF nr = error_part_nr
THEN print_alfa('<*>')
ELSE BEGIN
IF nr < 10
THEN print_alfa( chr(nr + ord('0')) )
ELSE print_alfa( chr((nr DIV 10) MOD 10 + ord('0'))
+ chr(nr MOD 10 + ord('0')) )
END
END;
[HIDDEN] PROCEDURE print_type(type_ptr:ttype);
(* This procedure prints a formal type using type_ptr. A concluded formal *)
(* type as a pair of brackets "<" and ">" around it. An error formal type is *)
(* printed as "<<*>>", and an undefined formal type as "<*>". *)
BEGIN
WITH type_ptr
DO BEGIN
IF conc
THEN print_char('<');
print_node(type_name);
IF conc
THEN print_char('>');
END
END;
|
(* The following procedure is for printing of expressions *)
[HIDDEN] PROCEDURE print_expr(expr_ptr : pexpr);
(* This procedure prints the expression, pointed to by expr_ptr. If expr_ptr *)
(* is NIL, "<NIL>" is printed, otherwise one of the tree kinds of expressions *)
(* is printed. *)
PROCEDURE print_lexpr(lexpr_ptr : plexpr);
(* This procedure prints a list of expressions pointed to by lexpr_ptr, *)
(* separated by commas. This procedure is used for printing the applied *)
(* argument expression within a function. *)
VAR
walker : plexpr;
BEGIN
walker := lexpr_ptr;
WHILE walker <> NIL
DO BEGIN
print_char('{');
print_alfa(walker^.type_of_arg);
print_char('}');
print_expr(walker^.first);
walker := walker^.rest;
IF walker <> NIL
THEN print_alfa(', ');
END
END;
PROCEDURE print_lalt_expr(alt_ptr : plalt_expr);
(* This procedure prints a list of case alternatives pointed to by alt_ptr. *)
(* The alternatives are separated by semi-colons, and every alternative *)
(* consists of a selector and an expression. *)
VAR
walker : plalt_expr;
PROCEDURE print_selectors(other_sel : boolean; selector : elements);
(* This procedure prints a list of element names pointed to by the pointer*)
(* lnode_ptr, separated with commas or "OTHERS" if lnode_ptr is equal to *)
(* others_selector. It is used to print a selector. *)
VAR
elemnr : integer;
BEGIN
IF other_sel
THEN print_alfa('OTHERS')
ELSE BEGIN
elemnr := start_nr;
WHILE selector <> []
DO BEGIN
next_elem(elemnr, selector);
print_node(element[elemnr]);
IF selector <> []
THEN print_char(',')
END
END
END;
BEGIN (* of print_lalt_expr *)
walker := alt_ptr;
WHILE walker <> NIL
DO BEGIN
WITH walker^
DO BEGIN
print_selectors(other_sel, selectors);
print_alfa(' : ');
print_expr(expr)
END;
walker := walker^.rest;
IF walker <> NIL
THEN print_alfa('; ');
END
END;
BEGIN (* of print_expr *)
IF expr_ptr = NIL
THEN print_alfa('<NIL>')
ELSE WITH expr_ptr^
DO CASE kind OF
e_atoc : BEGIN
print_node(attr);
print_alfa(' OF ');
print_partnamenr(partnamenr)
END;
e_func : BEGIN
print_node(func);
print_char('(');
print_lexpr(args);
print_char(')')
END;
e_case : BEGIN
print_alfa('CASE ');
print_partnamenr(headpnnr);
print_alfa(' OF ');
print_lalt_expr(alter);
print_alfa(' ESAC')
END
END
END;
|
(* The following procedure is for printing a list of attribute assignments *)
[HIDDEN] PROCEDURE print_lattr_ass(aas_ptr : plattr_ass);
(* This procedure prints a list of attribute assignments, separated by *)
(* commas and starting on a new line. *)
VAR
walker : plattr_ass;
PROCEDURE print_lalt_ass(alt_ptr : plalt_ass);
(* This procedure prints a list of selective assignment alternatives, *)
(* pointed to by alt_ptr, separated by semi-colons and all starting on a *)
(* new line. *)
VAR
walker : plalt_ass;
PROCEDURE print_selectors(other_sel : boolean; selector : elements);
(* This procedure prints a selector of a selective assignment. If it is a *)
(* others selector, when list is equal others_selector, "OTHERS" is *)
(* printed. Otherwise all the elements represented by the list list are *)
(* printed under each other separated by commas. *)
VAR
elemnr : integer;
BEGIN
IF other_sel
THEN print_fixed('OTHERS',15)
ELSE BEGIN
elemnr := start_nr;
WHILE selector <> []
DO BEGIN
next_elem(elemnr, selector);
print_fixed(element[elemnr]^.name,15);
IF selector <> []
THEN BEGIN
print_char(',');
print_newline(1)
END
END
END
END;
BEGIN (* of print_lalt_ass *)
walker := alt_ptr;
WHILE walker <> NIL
DO BEGIN
print_newline(1);
WITH walker^
DO BEGIN
print_selectors(other_sel, selectors);
print_alfa(': ');
shift_right(17);
print_lattr_ass(attr_ass);
END;
walker := walker^.rest;
IF walker <> NIL
THEN print_char(';');
shift_left(17);
END
END;
BEGIN (* of print_lattr_ass *)
walker := aas_ptr;
WHILE walker <> NIL
DO BEGIN
shift_right(1);
WITH walker^
DO CASE kind OF
a_simp : BEGIN
print_node(attr);
print_alfa(' OF ');
print_partnamenr(partnamenr);
print_alfa(' = ');
print_expr(expr)
END;
a_sele : BEGIN
print_alfa('CASE ');
print_partnamenr(headpnnr);
print_alfa(' OF');
shift_right(2);
print_lalt_ass(alter);
shift_left(2);
print_newline(1);
print_alfa('ESAC')
END
END;
shift_left(1);
print_newline(1);
walker := walker^.rest;
IF walker <> NIL
THEN print_char(',')
END
END;
|
(* The procedures on this page print the information with the different *)
(* kinds of names. *)
[HIDDEN] PROCEDURE print_element(ptr : pnode);
(* This procedure prints the information of an element name. These are: The *)
(* names of the attributes defined with attribute rules. The words "ROOT *)
(* ELEMENT", if this is the root element. The class rule if it is not empty. *)
(* The kind of tree rule, and the tree rule if it is not empty. The attribute *)
(* assignments, if they are defined. *)
PROCEDURE print_attrs(attr : tattr);
(* This procedure prints the attributes, represented by attr_ptr. Every *)
(* attribute is printed on a new line. It is preceded by "-", and behind it *)
(* are the words "INPUT" and "OUTPUT" printed, if there has been an *)
(* interface rule with this kind and with this element. *)
VAR
attrnr : integer;
BEGIN
attrnr := start_nr;
WHILE attr[nor_gen] <> []
DO BEGIN
next_attr(attrnr, attr[nor_gen]);
print_alfa('- ');
print_fixed(attribute[attrnr]^.name, 35);
IF attrnr IN (attr[nor_in] + g_input_attr)
THEN print_alfa(' INPUT ');
IF attrnr IN (attr[nor_out] + g_output_attr)
THEN print_alfa(' OUTPUT');
print_newline(1)
END
END;
PROCEDURE print_elem_list(list : elements);
(* This procedure prints a list of elements with list. The names of the *)
(* elements are printed with their full names and separated by commas. *)
VAR
elemnr : integer;
BEGIN
elemnr := start_nr;
WHILE list <> []
DO BEGIN
next_elem(elemnr, list);
print_node(element[elemnr]);
IF list <> []
THEN print_alfa(', ');
END
END;
PROCEDURE print_kind_of_rule(kind : trule_kind);
(* This procedure prints the kind of the tree rule, using kind. *)
BEGIN
CASE kind OF
r_empt : print_alfa('EMPTY ');
r_dire : print_alfa('DIRECT ');
r_indi : print_alfa('INDIRECT ');
r_undf : print_alfa('UNDEFINED ')
END;
print_alfa('TREE RULE ')
END;
PROCEDURE print_tree_def(tree_rule_ptr : ptree_rule);
(* This procedure prints the tree rule, represented by tree_rule_ptr. It is *)
(* preceded with the symbol "=>". All the parts are printed on a new line, *)
(* separated with a comma. *)
VAR
walker : ptree_rule;
BEGIN
print_alfa('=> ');
shift_right(1);
walker := tree_rule_ptr;
WHILE walker <> NIL
DO BEGIN
WITH walker^
DO BEGIN
print_fixed(partname, 15);
print_alfa(': ');
print_node(element)
END;
print_newline(1);
walker := walker^.rest;
IF walker <> NIL
THEN print_alfa(', ');
END;
print_alfa('. ');
shift_left(1);
print_newline(1)
END;
BEGIN (* of print_element *)
WITH ptr^
DO BEGIN
reset_left_margin(2);
print_newline(1);
print_attrs(attr);
IF ptr = root
THEN BEGIN
write(listing,'ROOT ELEMENT');
print_newline(1)
END;
IF parent <> []
THEN BEGIN
print_alfa('IN CLASSES : ');
shift_right(13);
print_elem_list(parent);
shift_left(13);
print_newline(1)
END;
IF class_rule <> []
THEN BEGIN
print_alfa('= {');
shift_right(3);
print_elem_list(class_rule);
print_char('}');
shift_left(3);
print_newline(1)
END;
print_kind_of_rule(kind_of_rule);
print_newline(1);
IF tree_rule <> NIL
THEN print_tree_def(tree_rule);
IF attr_ass <> NIL
THEN BEGIN
print_char('[');
print_lattr_ass(attr_ass);
print_char(']');
END
END
END;
|
[HIDDEN] PROCEDURE print_attribute(ptr : pnode);
(* This procedure prints the information with an attribute, represented by *)
(* ptr. The formal type is printed, followed by information about the kind of *)
(* attribute, and indications whether an interface rule (without "at") *)
(* occurred with this attribute. *)
BEGIN
WITH ptr^
DO BEGIN
reset_left_margin(2);
print_newline(1);
print_alfa(': ');
print_type(type_of_attr);
print_alfa(' ');
IF attr_nr <> error_nr
THEN BEGIN
IF attr_nr IN g_inh_attr
THEN write(listing,'INHERITED ')
ELSE IF attr_nr IN g_syn_attr
THEN write(listing,'SYNTHESIZED')
ELSE write(listing,'UNDEFINED ');
IF attr_nr IN g_input_attr
THEN write(listing,' INPUT');
IF attr_nr IN g_output_attr
THEN write(listing,' OUTPUT');
END
END
END;
|
[HIDDEN] PROCEDURE print_function(ptr : pnode);
(* This procedure print information about a function represented by ptr. *)
(* Which is the formal parameter list, preceded by an "=" symbol. *)
VAR
walker : pltype;
BEGIN
WITH ptr^
DO BEGIN
reset_left_margin(2);
print_newline(1);
print_alfa('= ');
print_char('(');
shift_right(3);
walker := args;
WHILE walker <> NIL
DO BEGIN
print_type(walker^.first);
walker := walker^.rest;
IF walker <> NIL
THEN print_alfa(', ')
END;
print_alfa(') ');
print_alfa(': ');
print_type(type_of_func)
END
END;
|
(* The procedures on this pages print the identifier tree in alphabetical *)
(* order. *)
[HIDDEN] PROCEDURE print_name_tree(ptr : pnode; depth : integer);
(* This procedure prints the sub-tree below the pointer ptr, with all its *)
(* information. *)
PROCEDURE print_info;
(* This procedure prints the information with a name. Information about *)
(* the error status is also printed. *)
PROCEDURE print_n_kind(kind : tnode_kind);
(* This procedure prints the kind of a name. *)
BEGIN
CASE kind OF
n_class : write(listing,'CLASS ');
n_node : write(listing,'NODE TYPE');
n_elem : write(listing,'ELEMENT ');
n_type : write(listing,'TYPE ');
n_func : write(listing,'FUNCTION ');
n_attr : write(listing,'ATTRIBUTE');
n_system : write(listing,'SYSTEM ');
n_pascal : write(listing,'PASCAL ');
n_undef : write(listing,'UNDEFINED');
END
END;
PROCEDURE print_error_status(status : terror_sts);
(* This procedure prints an error status, if it is unequal the correct *)
(* error status. *)
VAR
kind : tnode_kind;
BEGIN
WITH status
DO BEGIN
IF conc
THEN write(listing,' CONCLUDED');
IF defined <> []
THEN BEGIN
write(listing,' {');
kind := n_class;
REPEAT
WHILE NOT(kind IN defined)
DO kind := succ(kind);
print_n_kind(kind);
defined := defined - [kind];
IF defined <> []
THEN write(listing,',');
UNTIL defined = [];
write(listing,'}')
END
END
END;
BEGIN (* of print_info *)
WITH ptr^
DO BEGIN
reset_left_margin(0);
print_newline(1);
write(listing,name,' ');
print_n_kind(kind);
write(listing,'[',depth:2,']');
print_error_status(status);
CASE kind OF
n_class ,
n_node ,
n_elem : print_element(ptr);
n_attr : print_attribute(ptr);
n_func : print_function(ptr);
OTHERWISE
END
END
END;
BEGIN (* begin of print_name_tree *)
IF ptr <> NIL
THEN WITH ptr^
DO BEGIN
print_name_tree(left,depth+1);
IF with_all_names OR (kind < n_system)
THEN print_info;
print_name_tree(right,depth+1)
END
END;
PROCEDURE print_tree;
(* This procedure prints the entire identifier tree. *)
BEGIN
perf_start_time(perf_print_id);
print_newline(2);
write(listing,'Information of the defined identifiers :');
IF with_all_names
THEN write(listing,' (including predefined identifiers)');
print_newline(1);
print_name_tree(nametree,0);
perf_end_time (perf_print_id);
END;
END.
|
My life as a hacker | My home page