|
|
This module contains the parser of the input grammar. All of the type checking and some other semantic checks are done by this module.
In the following sections we describe the procedures that parse the production rules using the non-terminals of the grammar. For each procedure we also describe which of the semantic restrictions are tested.
The input grammar is described by the following grammar:
input grammar
: ( OPTIONS , option LIST , . )OPTION
: ( CLASSES , class LIST , . )OPTION
, NODE TYPES , node type LIST , .
, ( TYPES
, user defined type identifier LIST , .
)OPTION
, ( FUNCTIONS , semantic function definition SEQ
)OPTION
, ATTRIBUTES , attribute definitions SEQ
, ( INPUT , interface rule SEQ)OPTION
, ( OUTPUT , interface rule SEQ)OPTION
, RULES , rule SEQ
, ROOT , element
.
The procedure parser reads the input according to the input grammar. This procedure has the following structure:
PROCEDURE parser; BEGIN read_options; read_classes; read_node_types; read_types; read_semantic_functions; read_attributes; read_input_rules; read_output_rules; read_rules; read_root; skip_rubbish(inpas, []) END;
In the following sections we describe each of the procedures that are called.
The procedure read options reads the options according to the following grammar:
( OPTIONS , option LIST , . )OPTION
options : questions ; no questions
; names ; no names ; all names ; no all names
; trace ; no trace ; statistics ; no statistics
; warnings ; errors ; fatals
; orthogonal ; no orthogonal
; all ; none
.
The procedure read classes reads the enumeration of the classes according to the grammar:
( CLASSES , class LIST , . )OPTION . class : identifier .
This procedure calls the procedure read names, with the argument n class. The header of this procedure is:
PROCEDURE read_names(kind : tnode_kind);
This procedure is used for reading the enumeration of the classes, the node types and the types, due to their similarity. The parameter kind determines whether an enumeration of classes, node types or types is to be read. The procedure double enumerated [errors 3.3.1] is used to signal double enumerations to the error-handler.
The procedure read node types reads the enumeration of the node types according to the grammar:
NODE , TYPES , node type LIST , . . node type : identifier .
This procedure calls the procedure read names, with the argument n node.
The procedure read node types reads the enumeration of the node types according to the grammar:
( TYPES , user defined type identifier LIST , . )OPTION . user defined type identifier : identifier .
This procedure calls the procedure read names, with the argument n type.
The procedure read semantic functions reads the enumeration of the function definitions according to the grammar:
( FUNCTIONS , semantic function definition SEQ )OPTION .
semantic function definition
: semantic function identifier
, type identifier LIST PACK
, : , type identifier , .
.
semantic function identifier : identifier .
This procedure calls the procedure read one semantic function which reads the declaration of one semantic function, and stores the declaration in the binary identifier tree [bintree 1.10.4].
The procedure read attributes reads the enumeration of attribute definitions according to the following grammar:
ATTRIBUTES , attribute definition SEQ
attribute definition
: attribute identifier , : , type identifier
, (synthesized symbol ; inherited symbol) , OF
, element LIST , .
.
attribute identifier : identifier . synthesized symbol : SYN ; SYNTHESIZED . inherited symbol : INH ; INHERITED .
This procedure calls the procedure read one attribute, which reads one attribute definition, and stores the type of the attribute in the binary identifier tree [bintree 1.10.3]. The global variables g syn attr and g inh attr [bintree 2.3] are updated depending on whether the attribute is declared as a synthesized or an inherited attribute. The relation "attr of" is updated with the attribute for each element that is enumerated in the attribute definition, by calling the procedure add attr [bintree 1.8,1.10.2].
The procedures read input rules and read output rules reads the input and the output rules according to the following grammar:
( INPUT , interface rule SEQ )OPTION ,
( OUTPUT , interface rule SEQ )OPTION
interface rule
: attribute identifier , ( AT , element LIST )OPTION , .
.
Both procedures call the procedure read io rules, with an argument indicating what kind of rules need to be read. The procedure read io rules reads all the interface rules. The parameter io kind determines whether input or output interface rules are read. The interface rules with no AT-clause are stored in the global variables g input attr and g output attr [bintree 2.3]. For the interface rules with an AT-clause and a list of elements, the record field attr is updated by calling the procedure set io attr at elem [bintree 1.8,1.10.2].
The procedure read rules reads the grammar rules according to the grammar:
RULES , rule SEQ
This procedure calls the procedure exp rule, which reads one grammar rule according to the grammar:
rule : (tree rule ; class definition) , . .
tree rule : element , =>
, (part name , : , element)LIST
, attribute assignments OPTION
.
class definition : class , =
, { , element LIST , }
.
This procedure tries to determine whether a tree rule or a class definition is expected, and if successful, will call either the procedure exp tree rule or exp class rule. These procedures are explained in the following subsections.
The procedure exp class rule reads a class definition. The parameter class ptr of type pnode points to the class identifier that has been read before this procedure is called. The equal and open bracket symbol have also been read before this procedure is called. This procedure checks whether the class identifier is a class which has no class definition as yet. An error is generated when this is not the case, and the rest of the class definition is skipped without checking the syntax. Otherwise, the record field class rule [bintree 1.10.2] of the class identifier is filled with the result of the function exp cl elements, which reads the enumeration of elements of this class, and the consistency of the rules is checked by calling the procedure test consistency, see subsection 9.3
The function exp cl elements returns the element that forms the elements of the class. These elements are read and added to the returned set by calling the procedure add element in class.
The procedure add element in class tries to add the element in the class definition. A warning is generated if the element is already in the class definition. Error messages are also generated if adding the element would create a recursive class definition, or if an element is in more than one class in the case that the option was given that forbids this. The boolean function c in clos c or and is used to test whether a recursive class definition would be introduced.
The boolean function c in clos c or and returns TRUE if the element pointed to by the first parameter class is equal to, or in the closure of the class of the element pointed to by the second parameter elem from. Otherwise it returns FALSE.
The procedure exp tree rule reads the tree rule, followed by the optional attribute assignments. The parameter elem ptr of type pnode points to the left-hand side element of the tree rule. The right-hand side of the tree rule is read by calling the function exp tree def, and the attribute assignments are read by calling the function exp list attr ass, whenever these are given. The record fields tree rule, kind of rule and attr ass [bintree 1.10.2] of the left-hand side element are updated, and error messages are generated whenever this leads to errors. The consistency [4.7.2.1] is tested by calling the procedure test consistency, see following subsection.
The function exp tree def returns the right-hand side part of the tree rule, which is read behind the arrow symbol. The function test partnames is called to test whether there are no duplicate part names in the tree rule. Error messages are generated whenever syntax errors are detected.
The consistency restrictions on the tree rules and class definitions are performed on-the-fly, whenever a rule is read. These restrictions are needed to make the definition of the "tree production of" function possible. This function is represented in the record field tree rule of the element identifiers in the binary tree, and is step-wise constructed when the consistency is checked.
The procedure test consistency tests the consistency in the class hierarchy under the element pointed to by the parameter elem ptr. In the case that there has been a class definition the test is performed by propagating the tree production to all the elements of the class definition of this element, and the procedure is called recursively for all these elements. If the procedure detects in the process of propagation that more than one tree production is defined with the same element, a fatal error message is generated.
The function exp list attr ass of type plattr ass [bintree 1.5] returns the representation of a list of attribute assignments read by the function, according to the following grammar:
attribute assignments : [ , attribute assignment LIST , ] .
attribute assignment
: simple attribute assignment
; selective assignment
.
The first parameter followers contains the set of followers which is the set of symbols that may not be skipped. The second boolean parameter topnivo is equal to TRUE if the attribute assignments that are read are not within a selective assignment, otherwise it has the value FALSE.
The parameters allowedpn and correctpn are used by the process that finds a correct part name within a selective assignment. The fourth boolean parameter correctpn is set to TRUE when a correct part name has been found. Correct part names are the part names of the tree rule with these attribute assignments. If a correct part name has been found, the third parameter allowedpn contains, the representation of the first found correct part name, otherwise the alphabetic representation of the last found incorrect part name. These parameters are updated by the procedure process partname, which is not described further here.
The function exp list attr ass calls the procedure exp simp ass if a simple attribute assignment has been detected, and the procedure exp sel ass if a selective assignment has been detected. These procedures are discussed in the following subsections.
The procedure exp simp ass reads a simple attribute assignment according to the following grammar:
simple attribute assignment
: attribute identifier , OF , part name
, = , expression
.
The parameter attr ptr points to the attribute identifier that has been read before the procedure was called. The procedure calls the function exp expression to read the expression in the simple attribute assignment. The function exp expression is described in section 11
The procedure exp sel ass reads a selective assignment according to the following grammar:
selective assignment
: CASE , part name , OF
, selection alternatives
, ESAC
.
The parameter hpartname nr contains the part name number of the selective assignment that has been read before the procedure was called.
The function exp sel alt of type plalt ass returns the list of selection alternatives that are read by the function according to the following grammar:
selection alternatives
: selector , : , attribute assignment LIST
, ( ; , selection alternatives )OPTION
; OTHERS , : , attribute assignment LIST
.
The parameter previous contains all the elements that have been used in the preceding selectors. The selectors are read by the function exp selectors, see section 12
The function exp expression of type pexpr returns the expression read by the function according to the following grammar:
expression : attribute occurrence
; semantic function expression
; case expression
.
The first parameter type ptr of type ttype [bintree 1.9] contains the representation of the formal type of the expression. The second parameter followers contains the symbols that may not be skipped in a skipping action within the expression that is being read by the function.
This function calls the function exp simple expr if a simple expression has been detected, the function exp sem func expr if a semantic function expression has been detected, and the function exp case expr if a case expression has been detected. These procedures are described in the following subsections.
The function exp expression is quite complicated because it first reads a number of symbols and tries to choose the best function (from the three above). This is done to increase the robustness of parsing of the expressions.
The function exp simple expr of type pexpr returns the representation of an attribute occurrence, according to the following grammar:
attribute occurrence
: attribute identifier , OF , part name .
The first parameter type ptr of type ttype [bintree 1.9] contains the representation of the formal type of the expression. The second parameter attr ptr of type pnode contains the attribute identifier and the third parameter hpartname nr contains the number of the part name that was recognized by the function exp expression before it called this function. This function checks whether this attribute is an applied attribute, using the procedure applied attr (see subsection 15.2), and whether the type of the expression matches the type of the attribute, using the procedure test types [errors 4].
The function exp sem func expr of type pexpr returns the representation of a semantic function application, according to the following grammar:
semantic function application
: semantic function identifier , expression LIST PACK .
The first parameter type ptr of type ttype [bintree 1.9] contains the representation of the formal type of the expression. The third parameter hsym of type alfa contains the alphabetic representation of the semantic function identifier, which has been read before this procedure was called. The second parameter ident of type pnode points to the node in the binary tree of the identifier with the alphabetic representation hsym, if it exists, otherwise the second parameter is equal to NIL. The fourth parameter followers contains the symbols that may not be skipped in a skipping action within the expression that is being read by this function. The open bracket symbol of the pack has been read before this procedure is called.
The function exp sem func expr reads the argument list of the semantic function application and checks this list against the type of the function. There are three functions that are used to read this argument list stored by means of the type plexpr [bintree 1.4]. The function read test is used to read a list of arguments and checks the types of arguments against the list of types that is represented by its first argument typel ptr. The function read simple is used to read a list of arguments without type checking. The procedure is used when there are more arguments given than in the function definition, and when the identifier represented by ident is not a semantic function identifier. The function read create reads a list of arguments and returns in its first parameter typel ptr a list of the types of the arguments read. The procedure is used to derive a type declaration of a (deduced) semantic function identifier whenever this identifier has not been declared before.
The function exp case expr of type pexpr returns the representation of a case expression according to the following grammar:
case expression
: CASE , part name , OF
, case expression alternatives
, ESAC
.
The first parameter type ptr of type ttype [bintree 1.9] contains the representation of the formal type of the expression. The second parameter hpartname nr contains the part name number of the case expression that has been read before the procedure was called. The third parameter followers contains the symbols that may not be skipped in a skipping action within the expression that is being read by the function.
The function exp case alt of type plalt expr returns the list of selection alternatives that are read by the function according to the following grammar:
case expression alternatives
: selector , : , expression
, ( ; , case expression alternatives)OPTION
; OTHERS , : , expression
.
The parameter previous contains all the elements that have been used in the preceding selectors. The selectors are read by the function exp selectors, see next section.
Selectors are found as a part of selective assignments (see 10.2) and case expressions (see 11.3). The procedure exp selectors reads selectors according to the following grammar:
selector : element identifier LIST .
The first reference parameter selector of type elements contains the elements of the selector read by the procedure. The second reference parameter previous of type elements contains the elements of the previously read selectors on entering the procedure, and is updated with the elements of the selector read on leaving the procedure. The third parameter followers contains the symbols that may not be skipped in a skipping action within the expression that is being read by the function.
The function exp element of type pnode tries to read an element identifier. A syntax error message is generated when an identifier is not found. If an undefined identifier is found, it is defined by the function as a deduced element identifier, and an error message is generated. If it was defined, but not as an element identifier, an error message is generated.
The procedure is class checks if the element pointed by the parameter elem ptr is defined as a class identifier. Nothing happens when the identifier is not defined at all. An error message is generated when it is a node type identifier. When the identifier is a concluded element identifier it is changed into a concluded class identifier.
The procedure exp type tries to read a type identifier and returns in the parameter result of type ttype the formal type of the identifier. The parameter result is equal to the formal type variable und type if no type identifier is found. If the identifier is not yet defined it will be defined as a deduced type identifier by the procedure. If the identifier is not a type identifier, it is registered that it is used as a type identifier. Appropriate error messages are generated.
The function expr attr name of type pnode reads and returns an attribute identifier. When no identifier is found the function returns NIL, and an error message is generated. An error message is generated when the identifier is not defined as an attribute identifier.
The procedures inherited attr and synthesized attr check whether the attribute pointed to by the first parameter attr ptr is an inherited attribute or a synthesized attribute, respectively. If this is not true, an error message of the kind determined by the second parameter err is generated. If the attribute is not defined as synthesized or inherited, it is changed into a deduced inherited or a deduced synthesized attribute, respectively.
The procedures assigned attr and applied attr check whether the attribute pointed to by the first parameter attr ptr is an assigned attribute or an applied attribute, respectively, depending on the part name as represented by the second parameter partname. If the part name is not defined, no check is performed. Otherwise, one of the procedures synthesized attr or inherited attr is called.
In this section we will describe a number of functions that are used in reading and processing the part names in the attribute assignments and the expression.
The function exp partname of type alfa returns the alphabetic representation of a part name. This can either be the alphabetic representation of an identifier or the symbol #. When none of these is found the value of the constant error partname is returned, and an error message is generated.
The function nr of partname of type integer returns the number of the partname with the alphabetic representation stored in the parameter hulpsym. It uses the global variable partnames of type ptree rule which points to the last read tree rule. The alphabetic representation of the main part name is converted into the value of the constant main part nr. The function returns the value of the constant error part nr if the alphabetic representation is not a part name of the last read tree rule, otherwise it returns the index of part name in the tree rule. The index of the first part name is one.
The function exp test partname of type integer returns the number of the part name which it reads. If it does not read a valid part name, the value that is returned is equal to the value of the constant error part nr, and an error message is generated. The function makes use of the two functions described in the previous subsections.
The function partname with of type alfa returns the alphabetic representation with the part name number of the parameter partname nr. The value '<ERROR>' is returned if partname nr is equal to the value of the constant error part nr.
The procedure read root reads the root element identifier and stores it in the global variable root [bintree 2.2].
This module uses declarations from the following modules:
screen, definitions, perform, errors, scanner, bintree.
The following constant declarations are exported:
main_partname = '# '; { alfa representation of main partname }
error_partname = '*ERRORPART'; { alfa representation of error partname }
undef_partname = '*UNDEFPART'; { alfa representation of undefined partname }
skip = TRUE;
do_not_skip = FALSE;
This module only exports the following procedure:
PROCEDURE parser;
In This section the complete listing is given. The listing has been split into separate subsections to display the logical subdivision of the entire listing.
[ENVIRONMENT ('parser.pen'),
INHERIT ('[-.screen]screen.pen',
'definitions.pen',
'perform.pen',
'errors.pen',
'scanner.pen',
'bintree.pen')]
MODULE parser;
(* This program contains the parser of the input. The procedures in this *)
(* program do the syntactical parsing of the input, and perform some type *)
(* checking, both of the used identifiers(names) and the expressions. It *)
(* can been seen as the first pass of this compiler-compiler. *)
|
CONST main_partname = '# '; (* alfa repr. of main partname *) error_partname = '*ERRORPART'; (* alfa repr. of error partname *) undef_partname = '*UNDEFPART'; (* alfa repr. of undefined partname *) skip = TRUE; do_not_skip = FALSE; |
VAR (* local for this program *) error_ptr : [HIDDEN] pnode; (* used when reading double definitions *) partnames : [HIDDEN] ptree_rule; (* holding last read tree rule *) |
PROCEDURE exp_comma;
(* This procedure is used when a comma in a list-construct is wanted *)
BEGIN
IF scansym = comma_sym
THEN nextsym(inpas)
ELSE IF scansym = some_sym
THEN error(m_sex, ',')
END;
PROCEDURE sup_comma;
(* This procedure is used for a superfluous comma *)
BEGIN
error(s_scm);
nextsym(inpas)
END;
FUNCTION test_kind(p:pnode; k:tnode_kind) : boolean;
(* This function tests whether the kind of (possibly empty) node p is equal *)
(* kind k *)
BEGIN
IF p = NIL
THEN test_kind := FALSE
ELSE test_kind := (p^.kind = k)
END;
|
(* The procedures on this page are for reading the options from the input, *)
(* according the grammar: *)
(* *)
(* grammar : (options symbol , options LIST , period symbol)OPTION . *)
(* *)
(* options : QUESTIONS ; NO_QUESTIONS ; NAMES ; NO_NAMES ; ALL_NAMES *)
(* ; NO_ALL_NAMES ; TRACE ; NO_TRACE ; STATISTICS ; NO_STATISTICS *)
(* ; WARNINGS ; ERRORS ; FATALS ; ORTHOGONAL ; NO_ORTHOGONAL ; *)
(* ; ALL ; NONE *)
(* . *)
(* *)
PROCEDURE read_options;
(* This procedure reads the options from the input, if the keyword OPTIONS *)
(* is found *)
VAR
i : integer;
PROCEDURE init_options;
(* This procedure initializes the options to their default values *)
BEGIN
ask := FALSE;
with_names := FALSE;
with_all_names := FALSE;
with_tracing := FALSE;
with_statistics := FALSE;
min_error_kind := t_fat;
with_orthogonal := FALSE;
END;
PROCEDURE read_one_option;
(* This procedure processes one option, using the alfa representation. *)
BEGIN
add_level_info(sym);
CASE sym.length OF
3 : IF sym = 'all' THEN BEGIN
ask := FALSE;
with_names := TRUE;
with_all_names := TRUE;
with_tracing := TRUE;
with_statistics := TRUE;
min_error_kind := t_war;
with_orthogonal := TRUE;
END;
4 : IF sym = 'none' THEN init_options;
5 : IF sym = 'names' THEN with_names := TRUE ELSE
IF sym = 'trace' THEN with_tracing := TRUE;
6 : IF sym = 'errors' THEN min_error_kind := t_err ELSE
IF sym = 'fatals' THEN min_error_kind := t_fat;
8 : IF sym = 'no_names' THEN with_names := FALSE ELSE
IF sym = 'no_trace' THEN with_tracing := FALSE ELSE
IF sym = 'warnings' THEN min_error_kind := t_war;
9 : IF sym = 'questions' THEN ask := TRUE ELSE
IF sym = 'all_names' THEN with_all_names := TRUE;
10 : IF sym = 'statistics' THEN with_statistics := TRUE ELSE
IF sym = 'orthogonal' THEN with_orthogonal := TRUE;
12 : IF sym = 'no_all_names' THEN with_all_names := FALSE ELSE
IF sym = 'no_questions' THEN ask := TRUE;
13 : IF sym = 'no_statistics' THEN with_statistics := FALSE ELSE
IF sym = 'no_orthogonal' THEN with_orthogonal := FALSE
OTHERWISE error(e_uop)
END;
nextsym(inpas)
END;
BEGIN (* of read_options *)
skip_rubbish(inpas,
[options_sym,classes_sym,node_sym,types_sym,functions_sym,
types_sym,functions_sym,input_sym,output_sym,rules_sym,
root_sym]);
enter_level('options');
init_options;
IF scansym = options_sym
THEN BEGIN
nextsym(inpas);
WHILE scansym IN [some_sym,comma_sym]
DO IF scansym = some_sym
THEN BEGIN
read_one_option;
exp_comma
END
ELSE sup_comma;
back_on_the_rails(inpas, [period_sym],
[classes_sym,node_sym,types_sym,
functions_sym,attribute_sym,input_sym,output_sym,
rules_sym,root_sym], '.', m_sex, skip);
(* When ALL_NAMES is given, NAMES is included so: *)
IF with_all_names
THEN with_names := TRUE
END;
exit_level
END;
|
(* The procedures and functions on this page are for reading and testing *)
(* elements. *)
(* The following procedures are used to read the class and node type *)
(* definitions, using the grammar: *)
(* *)
(* class definitions *)
(* : (classes symbol , class LIST period symbol)OPTION . *)
(* node type definitions *)
(* : node types symbol , node type LIST , period symbol . *)
(* element : class ; node type . *)
PROCEDURE read_names(kind: tnode_kind);
(* This procedure reads names of kind kind closed with period_sym and *)
(* separated by single commas. The names are tested on double definitions. *)
(* If not so defined as names of kind kind *)
(* This procedure starts with a call to nextsym(inpas) ! *)
VAR
name_ptr : pnode;
BEGIN
nextsym(inpas);
WHILE scansym IN [some_sym,comma_sym]
DO IF scansym = some_sym
THEN BEGIN
IF NOT insert_name(nametree, sym, name_ptr, kind)
THEN double_enumerated(name_ptr,kind);
nextsym(inpas);
exp_comma
END
ELSE sup_comma;
back_on_the_rails(inpas, [period_sym], [node_sym,types_sym,functions_sym,
attribute_sym,input_sym,output_sym,rules_sym,root_sym],
'.', m_sex,skip)
END;
PROCEDURE read_classes;
(* This procedure reads the classes from the input, if the keyword CLASSES *)
(* is found using the procedure read_names. *)
BEGIN
enter_level('classes');
skip_rubbish(inpas, [classes_sym,node_sym,types_sym,functions_sym,
attribute_sym,input_sym,output_sym,rules_sym,root_sym]);
IF scansym = classes_sym
THEN read_names(n_class);
exit_level
END;
PROCEDURE read_node_types;
(* This procedure reads all the node types from the input using read names. *)
(* Syntax errors are generated when the keywords NODE TYPES are not found. *)
BEGIN
enter_level('node types');
back_on_the_rails(inpas, [node_sym], [types_sym,functions_sym,attribute_sym,
input_sym,output_sym,rules_sym,root_sym],
'NODE', s_mk1, do_not_skip);
IF scansym = node_sym
THEN BEGIN
nextsym(inpas);
expect(inpas, types_sym, do_not_skip, 'TYPES');
read_names(n_node)
END;
exit_level
END;
(* The following procedures are used when reading the tree and class rules. *)
FUNCTION exp_element : pnode;
(* This function tries to read an element from the input. If no name is *)
(* found a syntax error is generated. If the name was not yet defined, it *)
(* is defined as a concluded element, otherwise it is tested whether it is *)
(* defined as an element. Appropriate error messages are generated *)
VAR
elem_ptr : pnode;
BEGIN
enter_level('element');
IF scansym = some_sym
THEN (* a name is found *)
BEGIN
IF insert_name(nametree, sym, elem_ptr, n_elem)
THEN (* name not yet defined *)
BEGIN
error(e_nye);
conclude(elem_ptr);
exp_element := elem_ptr
END
ELSE IF NOT (elem_ptr^.kind IN [n_elem,n_class,n_node])
THEN (* name not defined as element *)
BEGIN
wrong(elem_ptr, n_elem);
exp_element := NIL
END
ELSE exp_element := elem_ptr;
nextsym(inpas)
END
ELSE (* no name is found *)
BEGIN
error(s_nex);
exp_element := NIL
END;
exit_level
END;
PROCEDURE is_class(VAR elem_ptr:pnode);
(* This procedure tests whether element is a class. When it is not a class, *)
(* it is checked whether it might have been concluded as an element. If so *)
(* this element is converted into a concluded class. In both cases a normal *)
(* error message is generated. The returned elem_ptr is a class or NIL. *)
BEGIN
IF elem_ptr <> NIL
THEN IF elem_ptr^.kind = n_node
THEN (* it is defined as a node type *)
BEGIN
error(e_esc);
elem_ptr := NIL
END
ELSE WITH elem_ptr^
DO IF kind = n_elem
THEN (* it is defined as a concluded element *)
BEGIN
error(e_nyc);
kind := n_class
END
END;
|
(* The procedures on this page are for reading types. The grammar is: *)
(* *)
(* standard type identifiers *)
(* : INTEGER ; REAL ; BOOLEAN ; CHAR ; ASCII . *)
(* user type identifier definitions *)
(* : (type symbol *)
(* , user defined type identifier LIST , period symbol *)
(* )OPTION . *)
(* type identifier *)
(* : standard type identifier *)
(* ; user defined type identifier *)
(* . *)
(* The following procedure is used for reading the user defined type *)
(* definitions. *)
PROCEDURE read_types;
(* This procedure reads all the user defined types from the input, using *)
(* read_names, if the keyword TYPES is found. *)
BEGIN
enter_level('types');
skip_rubbish(inpas, [types_sym,functions_sym,attribute_sym,
input_sym,output_sym,rules_sym,root_sym]);
IF scansym = types_sym
THEN read_names(n_type);
exit_level
END;
(* The following procedure is used; to read types within semantic function *)
(* definitions and attribute definitions. *)
PROCEDURE exp_type(VAR result:ttype);
(* This function tries to read a type from the input. If no name is found a *)
(* syntax error is generated. If the name was not yet defined, it will be *)
(* defined as a concluded type. If it was defined as something else an *)
(* error is generated and it is recorded that this name is used as a type. *)
(* In both cases result will held a formal type. *)
BEGIN
enter_level('type');
IF scansym = some_sym
THEN (* a name is found *)
WITH result (* : RECORD type_name : pnode ; conc : boolean END *)
DO BEGIN
IF insert_name(nametree, sym, type_name, n_type)
THEN (* name is not yet defined *)
BEGIN
error(e_nyt);
conc := TRUE
END
ELSE IF type_name^.kind <> n_type
THEN (* name not defined as type *)
BEGIN
wrong(type_name, n_type);
conc := TRUE;
error_define(type_name,n_type)
END
ELSE (* a type name is found *)
conc := FALSE;
nextsym(inpas)
END
ELSE (* no name is found *)
BEGIN
error(s_nex);
result := und_type
END;
exit_level
END;
|
(* The procedures on this page are for reading the semantic function *)
(* definitions, using the grammar : *)
(* *)
(* semantic function definitions *)
(* : (functions symbol , semantic function definition SEQ)OPTION . *)
(* semantic function definition *)
(* : semantic function name *)
(* , type identifier LIST PACK *)
(* , colon symbol , type identifier , period symbol *)
(* . *)
PROCEDURE read_semantic_functions;
(* This procedure reads semantic function definitions from the input, if *)
(* the keyword FUNCTIONS is found, according to the above grammar. *)
PROCEDURE read_one_semantic_function;
(* This procedure reads one semantic definition from the input. If a name *)
(* is already defined an error message is generated, and actions are *)
(* taken so that the formal specification of the function is read but not *)
(* added to the identifier, by making use of the error_ptr. *)
VAR
func_ptr : pnode;
FUNCTION read_arguments(VAR arg : pltype) : integer;
(* This function gives the number of arguments read, and puts them in *)
(* the variable arg. *)
BEGIN
skip_rubbish(inpas, [some_sym,comma_sym,close_sym,colon_sym,period_sym,
attribute_sym,input_sym,output_sym,rules_sym,root_sym]);
IF scansym IN [comma_sym,some_sym]
THEN BEGIN
new(arg);
WITH arg^
DO BEGIN
exp_type(first);
exp_comma;
read_arguments := 1 + read_arguments(rest)
END
END
ELSE BEGIN
arg := NIL;
read_arguments := 0
END
END;
BEGIN(* of read_one_semantic_function *)
IF NOT insert_name(nametree, sym, func_ptr, n_func)
THEN (* name is already defined *)
BEGIN
double_define(func_ptr, n_func);
func_ptr := error_ptr;
func_ptr^.kind := n_func
END;
WITH func_ptr^ (* : RECORD nr_of_arg : integer ; type_of_func : ttype ; *)
(* args : pltype END (part of tnode !!) *)
DO BEGIN
nextsym(inpas);
expect(inpas, open_sym, skip, '(');
nr_of_arg := read_arguments(args);
expect(inpas, close_sym, skip, ')');
expect(inpas, colon_sym, skip, ':');
exp_type(type_of_func);
END;
back_on_the_rails(inpas, [period_sym], [attribute_sym,input_sym,output_sym,
rules_sym,root_sym], '.', m_sex, skip)
END;
BEGIN (* of read semantic function definitions *)
enter_level('functions');
skip_rubbish(inpas, [functions_sym,attribute_sym,input_sym,output_sym,
rules_sym,root_sym]);
IF scansym = functions_sym
THEN BEGIN
nextsym(inpas);
WHILE scansym = some_sym
DO read_one_semantic_function
END;
exit_level
END;
|
(* The procedures on this page are for reading and testing attributes. *)
(* Following procedure reads the attribute definitions, using the grammar: *)
(* *)
(* attribute definitions *)
(* : attributes symbol , attribute definition SEQ . *)
(* attribute definition *)
(* : attribute name , colon symbol , type identifier *)
(* , (synthesized symbol ; inherited symbol) , of symbol *)
(* , element LIST , period symbol *)
(* . *)
PROCEDURE read_attributes;
(* This procedure reads all the attribute definitions according to the *)
(* above grammar from the input. If the keyword ATTRIBUTES is missing a *)
(* syntax error message is generated. *)
PROCEDURE read_one_attribute;
(* This procedure reads one attribute definition from the input. If a *)
(* name is already defined an error message is generated, and error_ptr *)
(* is used to read the definition, but not to add anything. *)
VAR
attr_ptr ,
elem_ptr : pnode;
PROCEDURE add_attr(VAR attr : attributes; attr_nr : integer);
(* This procedure adds an attribute, with number attr_nr, to the set of *)
(* attributes attr. If it is already in this set, a warning is given. *)
BEGIN
IF attr_nr <> error_nr
THEN IF attr_nr IN attr
THEN error(w_era)
ELSE attr := attr + [attr_nr]
END;
PROCEDURE read_attr_kind(attr_nr : integer);
(* This procedure reads the kind of an attribute. *)
BEGIN
CASE scansym OF
inh_sym : BEGIN
nextsym(inpas);
IF attr_nr <> error_nr
THEN g_inh_attr := g_inh_attr + [attr_nr]
END;
syn_sym : BEGIN
nextsym(inpas);
IF attr_nr <> error_nr
THEN g_syn_attr := g_syn_attr + [attr_nr]
END;
OTHERWISE error(m_sex)
END
END;
BEGIN (* of read_one_attribute *)
IF NOT insert_name(nametree, sym, attr_ptr, n_attr)
THEN (* name is already defined *)
BEGIN
double_define(attr_ptr,n_attr);
attr_ptr := error_ptr;
attr_ptr^.kind := n_attr
END;
nextsym(inpas);
WITH attr_ptr^ (* RECORD type_of_attr : ttype ; attr_kind : tattr_kind; *)
(* input,output : boolean END (part of tnode) *)
DO BEGIN
expect(inpas, colon_sym,skip, ':');
exp_type(type_of_attr);
read_attr_kind(attr_nr);
expect(inpas, of_sym,skip, 'OF');
(* process the element names as a list-construct: *)
WHILE scansym IN [some_sym,comma_sym]
DO IF scansym = some_sym
THEN BEGIN
elem_ptr := exp_element;
IF (attr_ptr <> error_ptr)
AND (elem_ptr <> NIL)
THEN add_attr(elem_ptr^.attr[nor_gen],attr_ptr^.attr_nr);
exp_comma
END
ELSE sup_comma
END;
back_on_the_rails(inpas, [period_sym], [input_sym,output_sym,rules_sym,root_sym],
'.', m_sex, skip)
END;
BEGIN (* of read_attributes *)
enter_level('attributes');
skip_rubbish(inpas, [attribute_sym,input_sym,output_sym,rules_sym,root_sym]);
IF scansym = attribute_sym
THEN BEGIN
nextsym(inpas);
WHILE scansym = some_sym
DO read_one_attribute
END;
exit_level
END;
(* the following function and procedures are used when reading and testing *)
(* attribute assignments. *)
FUNCTION exp_attr_name : pnode;
(* This function tries to read an attribute name. It gives error messages *)
(* when no attribute name is found. *)
VAR
attr_ptr : pnode;
BEGIN
enter_level('attribute');
IF scansym = some_sym
THEN (* a name is found *)
BEGIN
IF get_name(nametree, sym, attr_ptr)
THEN (* name is defined *)
IF attr_ptr^.kind <> n_attr
THEN (* name not defined as attribute *)
BEGIN
wrong(attr_ptr, n_attr);
attr_ptr := NIL
END;
nextsym(inpas)
END
ELSE (* no name is found *)
BEGIN
error(s_nex);
attr_ptr := nil
END;
exp_attr_name := attr_ptr;
exit_level
END;
PROCEDURE inherited_attr(attr_ptr : pnode; err : errors);
(* This procedure tests whether the attribute, pointed by attr_ptr, is an *)
(* inherited attribute. It generates an error message if not. *)
BEGIN
WITH attr_ptr^
DO IF NOT (attr_nr IN g_inh_attr)
THEN IF attr_nr IN g_syn_attr
THEN error(err,,concluded(attr_ptr))
ELSE BEGIN
conclude(attr_ptr);
g_inh_attr := g_inh_attr + [attr_nr]
END
END;
PROCEDURE synthesized_attr(attr_ptr : pnode; err : errors);
(* This procedure tests whether the attribute, pointed by attr_ptr, is a *)
(* synthesized attribute. It generates an error message if not. *)
BEGIN
WITH attr_ptr^
DO IF NOT (attr_nr IN g_syn_attr)
THEN IF attr_nr IN g_inh_attr
THEN error(err,,concluded(attr_ptr))
ELSE BEGIN
conclude(attr_ptr);
g_syn_attr := g_syn_attr + [attr_nr]
END
END;
PROCEDURE assigned_attr(attr_ptr:pnode; partname:integer);
(* This procedure tests whether the given attribute with the partname is an *)
(* assigned attribute. If not an error message is generated. *)
(* If the kind of attribute is undefined, the kind is updated and the error *)
(* status of the attribute becomes concluded. *)
BEGIN
IF partname <> error_part_nr
THEN WITH attr_ptr^
DO IF partname = main_part_nr
THEN synthesized_attr(attr_ptr, b_aap)
ELSE inherited_attr(attr_ptr, b_aap)
END;
PROCEDURE applied_attr(attr_ptr:pnode; partname:integer);
(* This procedure tests whether the given attribute with the partname is an *)
(* applied attribute. If not an error message is generated. *)
(* If the kind of attribute is undefined, the kind is updated and the error *)
(* status of the attribute becomes concluded. *)
BEGIN
IF partname <> error_part_nr
THEN WITH attr_ptr^
DO IF partname = main_part_nr
THEN inherited_attr(attr_ptr, b_aas)
ELSE synthesized_attr(attr_ptr, b_aas)
END;
|
(* The procedures on this page are for reading and testing the input and *)
(* output rules, using the following grammar *)
(* *)
(* input rules *)
(* : (input symbol , interface rule SEQ)OPTION . *)
(* output rules *)
(* : (output symbol , interface rule SEQ)OPTION . *)
(* interface rule *)
(* : attribute name , (at symbol , element LIST)OPTION *)
(* , period symbol *)
(* . *)
(* *)
(* Because there are two kinds of interface rules, these are implemented in *)
(* two different ways. Rules with no at-part will result in condition set at *)
(* the attribute, which is done by the procedure set_all_io_attr. Rules with *)
(* an at-part will result in condition set at all the attribute element *)
(* pairs with the elements taken from after the at-symbol, using the *)
(* procedure set_io_attr_at_elem. *)
PROCEDURE read_io_rules(io_kind : tinout_kind);
(* This procedure reads interface rules of kind io_kind *)
PROCEDURE read_one_io_rule;
(* This procedure reads one interface rule *)
VAR
attr_ptr ,
elem_ptr : pnode;
attrnr : integer;
PROCEDURE set_all_io_attr;
(* This procedure sets the in- or output condition for an attribute, *)
(* and warnings are generated when this has already been done. *)
BEGIN
WITH attr_ptr^
DO CASE io_kind OF
n_input : IF attr_nr IN g_input_attr
THEN error(w_idr)
ELSE g_input_attr := g_input_attr + [attr_nr];
n_output : IF attr_nr IN g_output_attr
THEN error(w_odr)
ELSE g_output_attr := g_output_attr + [attr_nr]
END
END;
PROCEDURE set_io_attr_at_elem;
(* This procedure sets the in- or output condition for an attribute *)
(* element pair. An error message is generated when this pair is not *)
(* defined in the attribute rules. Warnings are generated when the *)
(* condition has already been set. *)
BEGIN
IF attrnr <> error_nr
THEN WITH elem_ptr^
DO IF attrnr IN attr[nor_gen]
THEN CASE io_kind OF
n_input : IF attrnr IN (attr[nor_in] + g_input_attr)
THEN error(w_iar)
ELSE attr[nor_in] := attr[nor_in] + [attrnr];
n_output : IF attrnr IN (attr[nor_out] + g_output_attr)
THEN error(w_oar)
ELSE attr[nor_out] := attr[nor_out] + [attrnr]
END
ELSE error(b_nea,,error_defined(elem_ptr, n_attr))
END;
BEGIN (* of read_one_io_rule *)
attr_ptr := exp_attr_name;
IF attr_ptr <> NIL
THEN IF scansym = at_sym
THEN (* rule with at-part *)
BEGIN
nextsym(inpas);
attrnr := attr_ptr^.attr_nr;
(* this part reads and processes: element LIST *)
WHILE scansym IN [some_sym,comma_sym]
DO IF scansym = some_sym
THEN BEGIN
IF get_name(nametree, sym, elem_ptr)
THEN IF elem_ptr^.kind IN [n_class,n_node,n_elem]
THEN set_io_attr_at_elem
ELSE wrong(elem_ptr,n_elem)
ELSE missing(n_elem);
nextsym(inpas);
exp_comma
END
ELSE sup_comma
END
ELSE (* rule with no at-part *)
set_all_io_attr
ELSE wrong_or_missing(attr_ptr,n_attr);
back_on_the_rails(inpas, [period_sym], [input_sym,output_sym,rules_sym,root_sym],
'.', m_sex, skip)
END;
BEGIN (* of read_io_rules *)
nextsym(inpas);
WHILE scansym = some_sym
DO read_one_io_rule
END;
PROCEDURE read_input_rules;
(* This procedure reads the input rules, if the keyword INPUT is found. *)
BEGIN
enter_level('input_rules');
skip_rubbish(inpas, [input_sym,output_sym,rules_sym,root_sym]);
IF scansym = input_sym
THEN read_io_rules(n_input);
exit_level
END;
PROCEDURE read_output_rules;
(* This procedure reads the output rules, if the keyword OUTPUT is found. *)
BEGIN
enter_level('output rules');
skip_rubbish(inpas, [output_sym,rules_sym,root_sym]);
IF scansym = output_sym
THEN read_io_rules(n_output);
exit_level
END;
|
(* The functions on this page are used to read the partnames in the *)
(* attribute assignments. *)
FUNCTION exp_partname : alfa;
(* This function tries to read a representation of a partname, which can be *)
(* a name or the main symbol. The result is in the form of an alfa *)
(* representation. *)
BEGIN
enter_level('partname');
IF scansym = main_sym
THEN (* "#" found *)
BEGIN
exp_partname := main_partname;
nextsym(inpas)
END
ELSE IF scansym = some_sym
THEN (* name found *)
BEGIN
exp_partname := sym;
nextsym(inpas)
END
ELSE (* no "#" or name found *)
BEGIN
error(m_sex, 'partname');
exp_partname := error_partname
END;
exit_level
END;
FUNCTION nr_of_partname(hulpsym:alfa) : integer;
(* This function converts an alfa representation of a partname to a number *)
(* using the global variable partnames, which holds the description of the *)
(* last read tree rule. The main representation is converted to the *)
(* main partname_nr. If the name hulpsym is within the list, the order is *)
(* returned, which means that the name is a partname of this tree rule. *)
(* Otherwise the error partname number will be returned. *)
VAR
list : ptree_rule;
nr ,
result : integer;
BEGIN
IF hulpsym = main_partname
THEN nr_of_partname := main_part_nr
ELSE BEGIN
list := partnames;
nr := 1;
result := error_part_nr;
WHILE (list <> NIL) AND (result = error_part_nr)
DO IF list^.partname = hulpsym
THEN result := nr
ELSE BEGIN
nr := nr + 1;
list := list^.rest
END;
nr_of_partname := result
END
END;
FUNCTION exp_test_partname : integer;
(* This function tries to read a partname. It does this by first trying *)
(* a representation of a partname, and then tries to convert it. An error *)
(* message is generated if a name is found which is not a partname. *)
VAR
hulpsym : alfa;
hulpnr : integer;
BEGIN
hulpsym := exp_partname;
IF hulpsym = error_partname
THEN exp_test_partname := error_part_nr
ELSE BEGIN
hulpnr := nr_of_partname(hulpsym);
IF hulpnr = error_part_nr
THEN error(e_nip);
exp_test_partname := hulpnr
END
END;
FUNCTION partname_with(partname_nr : integer) : alfa;
(* This function returns the alfa representation with partname_nr *)
VAR
list : ptree_rule;
nr : integer;
BEGIN
IF partname_nr = error_part_nr
THEN partname_with := '<ERROR>'
ELSE IF partname_nr = main_part_nr
THEN partname_with := '#'
ELSE BEGIN
list := partnames;
nr := 1;
WHILE (nr < partname_nr) AND (list <> NIL)
DO BEGIN
list := list^.rest;
nr := succ(nr)
END;
IF list = NIL
THEN partname_with := '<***>'
ELSE partname_with := list^.partname
END
END;
(* NAME OF *)
FUNCTION name_of(node : pnode) : alfa;
(* This function returns the alfa representation of node. *)
BEGIN
IF node = NIL
THEN name_of := '<UNDEFINED>'
ELSE name_of := node^.name
END;
|
(* The procedure on this page is for reading selectors, which are found both *)
PROCEDURE exp_selectors(VAR selector, previous : elements;
followers : symbol_set);
(* This procedure reads a selector consisting of a number of elements. *)
(* If the selector is empty, a warning is generated. *)
VAR
no_more_sel : boolean;
name_ptr : pnode;
FUNCTION name_in_till : boolean;
(* This function tests whether the next name is defined as an attribute *)
(* or as a function. In that case it will return TRUE. A side effect is *)
(* that the variable name_ptr is set. *)
BEGIN
IF get_name(nametree, sym, name_ptr)
THEN name_in_till := (name_ptr^.kind IN [n_attr,n_func])
ELSE name_in_till := FALSE
END;
PROCEDURE add_name_in_sel;
BEGIN
WITH name_ptr^
DO IF elem_nr <> error_nr
THEN IF elem_nr IN previous
THEN error(e_eps)
ELSE IF elem_nr IN selector
THEN error(w_ers)
ELSE selector := selector + [elem_nr]
END;
BEGIN (* of exp_selectors *)
enter_level('selector');
selector := [];
no_more_sel := FALSE;
REPEAT
skip_rubbish(inpas, followers);
IF scansym = some_sym
THEN IF name_in_till
THEN (* an attribute or function name is found *)
no_more_sel := TRUE
ELSE BEGIN
IF name_ptr <> NIL
THEN IF name_ptr^.kind IN [n_class,n_node,n_elem]
THEN (* name is an element *)
BEGIN
add_level_info(name_ptr^.name);
add_name_in_sel
END
ELSE wrong(name_ptr, n_elem)
ELSE missing(n_elem);
nextsym(inpas);
(* looks whether there is more to read *)
skip_rubbish(inpas, followers);
IF scansym = comma_sym
THEN nextsym(inpas)
ELSE (* no comma *)
BEGIN
no_more_sel := TRUE;
IF scansym = some_sym THEN IF
get_name(nametree, sym, name_ptr) THEN IF
name_ptr^.kind IN [n_class,n_node,n_elem]
THEN (* next symbol is an element name *)
BEGIN
error(m_sex, ',');
no_more_sel := FALSE
END
END
END
ELSE IF scansym = comma_sym
THEN sup_comma
ELSE no_more_sel := TRUE
UNTIL no_more_sel;
IF selector = []
THEN error(w_ese);
previous := previous + selector;
exit_level
END;
|
(* The procedures and functions on this page are used to read expressions *)
(* within the attribute assignments. The grammar of the expressions is *)
(* given with the different functions. *)
FUNCTION exp_expression(VAR type_ptr:ttype; followers:symbol_set) : pexpr;
(* This procedure is used for reading an expression. Here there is only a *)
(* forward declaration. The grammar of an expression is: *)
(* *)
(* expression : attribute occurrence *)
(* ; semantic function application *)
(* ; case expression *)
(* . *)
(* *)
(* This function tries to determine the kind, and calls one of the *)
(* procedures: exp_simple_expr, exp_sem_func_expr or exp_case_expr. *)
(* In the comment it is stated what has been found so far, while reading *)
(* the input. It can been seen what conclusions are made. *)
VAR
res : pexpr;
ident : pnode;
hsym : alfa;
partname_nr : integer;
start_line : integer;
FUNCTION exp_simple_expr(VAR type_ptr:ttype; attr_ptr:pnode;
hpartname_nr:integer) : pexpr;
(* This function returns a simple expression, which is an attribute *)
(* occurrence. The grammar is : *)
(* *)
(* attribute occurrence *)
(* : attribute name , of symbol , part name . *)
(* *)
(* This function tests the type of the expression, using type_ptr. The *)
(* attribute name has been read and is representated by attr_ptr. The part *)
(* name has been read and converted into a number and is given by *)
(* hpartname_nr. It also tests whether the attribute is applied. *)
VAR
expr_ptr : pexpr;
BEGIN
add_level_info(name_of(attr_ptr) + ' OF ' + partname_with(hpartname_nr));
wait(0.8);
IF test_kind(attr_ptr,n_attr)
THEN BEGIN
applied_attr(attr_ptr, hpartname_nr);
test_types(attr_ptr^.type_of_attr, type_ptr)
END
ELSE wrong_or_missing(attr_ptr,n_attr);
new(expr_ptr,e_atoc);
WITH expr_ptr^
DO BEGIN
kind := e_atoc;
partnamenr := hpartname_nr;
attr := attr_ptr;
line_nr := start_line
END;
exp_simple_expr := expr_ptr
END;
FUNCTION exp_sem_func_expr(VAR type_ptr:ttype; ident:pnode; hsym:alfa;
followers:symbol_set) : pexpr;
(* This function reads a semantic function application, and returns the *)
(* result. The grammar is : *)
(* *)
(* semantic function application *)
(* : semantic function name , expression LIST PACK . *)
(* *)
(* This function tests the type of the expression, using type_ptr. The *)
(* function name is represented in hsym, and when already defined ident *)
(* holds a pointer to the node. The open symbol has been read. It reads the *)
(* applied argument expressions and they are processed. Type checking is *)
(* done if possible, and the number of arguments is checked with the *)
(* definition. In the case the function name is not defined it will be *)
(* defined as a concluded function name, and the formal type is retrieved *)
(* from the context. *)
VAR
stoppers ,
infollowers : symbol_set;
result : pexpr;
PROCEDURE test_correct_comma(first:boolean);
(* This procedure tests whether there should be a comma or not, and is *)
(* used in the tree procedures below to test the list-construct. If first *)
(* is TRUE, no comma should be found, otherwise a comma must be found. *)
BEGIN
IF scansym = comma_sym
THEN BEGIN
IF first
THEN error(s_scm);
nextsym(inpas)
END
ELSE BEGIN
IF NOT first
THEN error(m_sex, ',')
END
END;
FUNCTION read_simple(first:boolean) : plexpr;
(* This function reads the arguments without any type checking and does *)
(* not count the number of arguments in case there is no information *)
(* available of the applied function. It is also used when there are more *)
(* applied arguments than defined arguments. *)
VAR
result : plexpr;
BEGIN
skip_rubbish(inpas, infollowers);
IF scansym IN stoppers
THEN read_simple := NIL
ELSE (* more arguments *)
BEGIN
test_correct_comma(first);
new(result);
WITH result^
DO BEGIN
first := exp_expression(err_type, followers);
type_of_arg.length := 0;
rest := read_simple(FALSE)
END;
read_simple := result
END
END;
FUNCTION read_test(typel_ptr : pltype; first:boolean) : plexpr;
(* This function reads the arguments and tests whether the types and the *)
(* number of arguments is correct, using the type description represented *)
(* in typel_ptr. *)
(* Error messages are generated when the number is not correct. *)
VAR
result : plexpr;
BEGIN
skip_rubbish(inpas, infollowers);
IF scansym IN stoppers
THEN (* all arguments read *)
BEGIN
IF typel_ptr <> NIL
THEN (* more arguments defined *)
error(b_tfa,,concluded(ident));
read_test := NIL
END
ELSE (* more arguments to read *)
IF typel_ptr = NIL
THEN (* no more arguments defined *)
BEGIN
test_correct_comma(first);
error(b_tma,,concluded(ident));
read_test := read_simple(TRUE)
END
ELSE BEGIN
test_correct_comma(first);
new(result);
WITH result^
DO BEGIN
first := exp_expression(typel_ptr^.first,followers);
WITH typel_ptr^.first
DO IF type_name = NIL
THEN type_of_arg.length := 0
ELSE type_of_arg := type_name^.name;
rest := read_test(typel_ptr^.rest,FALSE)
END;
read_test := result
END
END;
FUNCTION read_create(VAR typel_ptr : pltype; first:boolean):plexpr;
(* This function reads a number of arguments, and uses this information *)
(* to construct a formal type definitions in the variable typel_ptr. *)
VAR
result : plexpr;
BEGIN
skip_rubbish(inpas, infollowers);
IF scansym IN stoppers
THEN BEGIN
typel_ptr := NIL;
read_create := NIL
END
ELSE (* more arguments to read *)
BEGIN
test_correct_comma(first);
new(typel_ptr);
typel_ptr^.first := und_type;
new(result);
WITH result^
DO BEGIN
first := exp_expression(typel_ptr^.first,followers);
WITH typel_ptr^.first
DO IF type_name = NIL
THEN type_of_arg.length := 0
ELSE type_of_arg := type_name^.name;
result^.rest := read_create(typel_ptr^.rest,FALSE)
END;
read_create := result
END
END;
FUNCTION number_of(args : pltype) : integer;
(* This function finds the number of arguments represented by the list of *)
(* types args. *)
VAR
result : integer;
BEGIN
result := 0;
WHILE args <> NIL
DO BEGIN
result := result + 1;
args := args^.rest
END;
number_of := result
END;
BEGIN (* of exp_sem_func_expr *)
followers := followers + [comma_sym,close_sym];
stoppers := followers + [end_of_file] - [comma_sym];
infollowers := followers + [case_sym,some_sym];
new(result,e_func);
WITH result^ (* RECORD func : pnode; args : plexpr END (part of texpr!!) *)
DO BEGIN
kind := e_func;
IF hsym.length = 0
THEN (* no name found *)
BEGIN
add_level_info('<MISSING>( ');
missing(n_func);
func := NIL;
args := read_simple(TRUE)
END
ELSE (* a name is found *)
IF ident <> NIL
THEN (* name is defined *)
BEGIN
func := ident;
add_level_info(ident^.name + '(');
IF ident^.kind = n_func
THEN (* name defined as function *)
BEGIN
test_types(ident^.type_of_func, type_ptr);
args := read_test(ident^.args, TRUE)
END
ELSE (* name not defined as function *)
args := read_simple(TRUE)
END
ELSE (* name is not yet defined *)
BEGIN
add_level_info(hsym + '(');
error(e_nyf);
insert_name(nametree, hsym, ident, n_func);
func := ident;
args := read_create(ident^.args, TRUE);
ass_conc_type(ident^.type_of_func, type_ptr);
ident^.nr_of_arg := number_of(ident^.args);
conclude(ident)
END;
line_nr := start_line
END;
expect(inpas, close_sym, skip, ')');
exp_sem_func_expr := result
END;
FUNCTION exp_case_expr(VAR type_ptr : ttype; hpartname_nr : integer;
followers : symbol_set) : pexpr;
(* This function reads a case expression, and returns the result. *)
(* The grammar is: *)
(* *)
(* case expression *)
(* : case symbol , part name , of symbol *)
(* , (selector , colon symbol , expression)CHAIN semicolon symbol *)
(* , (semicolon symbol , colon symbol , expression)OPTION *)
(* , esac symbol *)
(* . *)
(* selector : element LIST . *)
(* *)
(* This function takes care of the testing of the types by proceeding the *)
(* variable type_ptr to the function that reads the expressions. The *)
(* selectors are read and tested by the procedure exp_selectors. The case *)
(* symbol and the partname have been read. The partname is represented by *)
(* hpartname_nr. *)
VAR
expr_ptr : pexpr;
st_of_alt ,
st_of_expr ,
inselfollowers : symbol_set;
FUNCTION exp_case_alt(previous : elements) : plalt_expr;
(* This procedure reads one alternative of a case expression. *)
(* The alternative has the grammar: *)
(* *)
(* alternative : (selector ; others symbol) , colon symbol , expression . *)
(* *)
VAR
altexpr_ptr : plalt_expr;
BEGIN
skip_rubbish(inpas, st_of_alt);
IF scansym IN st_of_alt
THEN (* more alternatives *)
BEGIN
new(altexpr_ptr);
WITH altexpr_ptr^ (* = RECORD selectors : plnode; expr : pexpr; *)
(* rest : plalt_expr END (???) *)
DO BEGIN
line_nr := input_line_nr;
IF scansym = others_sym
THEN BEGIN
other_sel := TRUE;
selectors := [0..max_elem_nr] - previous;
nextsym(inpas)
END
ELSE BEGIN
other_sel := FALSE;
exp_selectors(selectors,previous,inselfollowers)
END;
back_on_the_rails(inpas, [colon_sym], st_of_expr, ':',
m_sex, skip);
expr := exp_expression(type_ptr, followers);
skip_rubbish(inpas, followers);
IF NOT other_sel
AND (scansym = semicolon_sym)
THEN BEGIN
nextsym(inpas);
rest := exp_case_alt(previous)
END
ELSE rest := NIL
END;
exp_case_alt := altexpr_ptr
END
ELSE exp_case_alt := NIL
END;
BEGIN (* of exp_case_expr *)
followers := followers + [semicolon_sym,esac_sym];
st_of_expr := followers + [case_sym,some_sym,of_sym,open_sym];
inselfollowers := st_of_expr + [comma_sym,colon_sym];
st_of_alt := followers + [others_sym,some_sym,comma_sym,colon_sym];
new(expr_ptr,e_case);
WITH expr_ptr^
DO BEGIN
add_level_info('CASE ' + partname_with(hpartname_nr) + ' OF');
kind := e_case;
headpnnr := hpartname_nr;
back_on_the_rails(inpas, [of_sym], st_of_alt, 'OF', m_sex, skip);
alter := exp_case_alt([]);
IF alter = NIL
THEN error(e_nae);
line_nr := start_line
END;
exp_case_expr := expr_ptr;
back_on_the_rails(inpas, [esac_sym],followers,'ESAC', m_sex, skip)
END;
BEGIN (* of exp_expression *)
enter_level('expression');
skip_rubbish(inpas, [case_sym,some_sym,of_sym,open_sym,main_sym]+followers);
start_line := input_line_nr;
IF scansym = case_sym
THEN (* " CASE " found *)
BEGIN
nextsym(inpas);
res := exp_case_expr(type_ptr, exp_test_partname, followers)
END
ELSE BEGIN
IF scansym = some_sym
THEN (* name found *)
BEGIN
hsym := sym;
IF get_name(nametree, sym, ident)
THEN (* name is defined *)
IF ident^.kind IN [n_attr,n_func]
THEN (* name defined as attribute or function *)
partname_nr := error_part_nr
ELSE (* try whether it is a partname *)
partname_nr := nr_of_partname(sym)
ELSE (* try whether it is a part name *)
partname_nr := nr_of_partname(sym);
nextsym(inpas)
END
ELSE (* no name is found *)
BEGIN
ident := NIL;
hsym.length := 0;
IF scansym = main_sym
THEN (* mainpartname found *)
BEGIN
partname_nr := main_part_nr;
nextsym(inpas)
END
ELSE partname_nr := error_part_nr
END;
(* hsym holds the alfa representation, if a name is found. *)
(* ident holds a pointer to a node, if a defined name is found. *)
(* partname holds an correct partname number if a partname is *)
(* found that in case of a name is not defined as a attribute or *)
(* a function. *)
skip_rubbish(inpas,
[of_sym,open_sym,case_sym,some_sym,main_sym]+followers);
CASE scansym OF
of_sym :
IF partname_nr = error_part_nr
THEN (* name "OF" found *)
BEGIN
nextsym(inpas);
res := exp_simple_expr(type_ptr, ident, exp_test_partname)
END
ELSE (* partname "OF" found *)
BEGIN
error(m_sex,'CASE');
res := exp_case_expr(type_ptr, partname_nr, followers)
END;
open_sym :
(* (name, "#" or nothing) "(" found *)
BEGIN
nextsym(inpas);
res := exp_sem_func_expr(type_ptr, ident, hsym, followers)
END;
main_sym :
(* (name or "#") "#" found *)
BEGIN
error(m_sex, 'OF');
nextsym(inpas);
res := exp_simple_expr(type_ptr, ident, main_part_nr)
END;
some_sym :
(* (name, or "#") name found *)
BEGIN
partname_nr := nr_of_partname(sym);
IF partname_nr = error_part_nr
THEN (* (name or "#") partname found *)
BEGIN
error(m_sex, 'OF');
res := exp_simple_expr(type_ptr, ident, partname_nr)
END
ELSE (* (name or "#") no-partname found *)
BEGIN
error(m_sex, '(');
res := exp_sem_func_expr(type_ptr, ident, hsym, followers)
END
END;
case_sym :
(* (name, "#") "CASE" found *)
IF test_kind(ident, n_func)
THEN (* function-name "CASE" found *)
BEGIN
error(m_sex, '(');
res := exp_sem_func_expr(type_ptr, ident, hsym, followers)
END
ELSE (* (no-function-name or "#") "CASE" found *)
BEGIN
error(s_rbc);
res := exp_case_expr(type_ptr, exp_test_partname, followers)
END
OTHERWISE BEGIN
error(s_ure);
res := NIL
END
END
END;
exp_expression := res;
exit_level
END;
|
(* The procedures on this page are for reading the attribute assignments. *)
(* The grammar is: *)
(* *)
(* attribute assignments *)
(* : open bracket symbol *)
(* , attribute assignment LIST *)
(* , close bracket symbol *)
(* . *)
(* attribute assignment *)
(* : attribute occurrence , equal symbol , expression *)
(* ; selective assignment *)
(* . *)
FUNCTION exp_list_attr_ass(followers:symbol_set; topnivo:boolean;
VAR allowedpn:alfa; VAR correctpn:boolean
):plattr_ass;
(* This function reads a list of attribute assignments by calling the *)
(* procedures exp_simp_ass and exp_sel_ass. *)
(* The variables allowedpn and correctpn are used by the process that finds *)
(* a correct partname within a selective assignment, as described in the *)
(* procedure below. The boolean topnivo is TRUE if this procedure is called *)
(* outside a selective assignment, otherwise FALSE. This is because the two *)
(* are somewhat different concerning the partnames that are allowed. *)
VAR
result : plattr_ass;
hulp_sym : alfa;
hpartname_nr : integer;
name_ptr : pnode;
start_line : integer;
PROCEDURE process_partname(test : boolean);
(* This procedure simulates a process which seeks the first correct *)
(* partname in a selective assignment and does not generate superfluous *)
(* error messages. The boolean test is TRUE if a correct partname is *)
(* found. *)
BEGIN
IF hulp_sym <> error_partname
THEN (* a alfa representation of partname has been read *)
IF allowedpn = undef_partname
THEN (* still no alfa representation of a partname found *)
BEGIN
allowedpn := hulp_sym;
IF test
THEN (* a correct partname found *)
correctpn := TRUE
ELSE (* name was not a correct partname *)
error(e_npn)
END
ELSE (* an alfa representation of a partname has been found before *)
IF allowedpn <> hulp_sym
THEN (* that alfa representation is unequal the last found *)
IF test
THEN (* The last one is a correct partname *)
BEGIN
error(w_wpc);
correctpn := TRUE;
allowedpn := hulp_sym
END
ELSE (* The last one is not a correct partname *)
error(e_wpn)
END;
PROCEDURE exp_simp_ass(attr_ptr:pnode);
(* This procedure reads a simple attribute assignment, with the grammar: *)
(* *)
(* simple attribute assignment : *)
(* : attribute occurrence , equals symbol , expression . *)
(* *)
(* This procedure tests the whether the attribute is used as an applied *)
(* attribute and the type of the attribute is given to the procedure that *)
(* reads the expression. The attribute name of the attribute occurrence *)
(* and the of symbol have been read. *)
VAR
hulp_part_nr : integer;
BEGIN
back_on_the_rails(inpas, [of_sym], [some_sym,main_sym,equal_sym,case_sym]
+ followers,'OF', m_sex, skip);
hulp_sym := exp_partname;
hulp_part_nr := nr_of_partname(hulp_sym);
add_level_info(name_of(attr_ptr) + ' OF ' + partname_with(hulp_part_nr)
+ ' := ');
IF topnivo
THEN (* outside any selective assignments *)
BEGIN
IF hulp_part_nr = error_part_nr
THEN error(e_npn)
END
ELSE (* within a selective assignment *)
process_partname(hulp_part_nr <> error_part_nr);
IF test_kind(attr_ptr,n_attr)
THEN assigned_attr(attr_ptr, hulp_part_nr);
back_on_the_rails(inpas, [equal_sym], [case_sym,some_sym] + followers,
'=', m_sex, skip);
new(result,a_simp);
WITH result^ (* RECORD attr : pnode; partname_nr : integer *)
(* expr : pexpr END (part of tlattr_ass !!) *)
DO BEGIN
kind := a_simp;
attr := attr_ptr;
partnamenr := hulp_part_nr;
IF test_kind(attr,n_attr)
THEN expr := exp_expression(attr^.type_of_attr,followers)
ELSE expr := exp_expression(err_type, followers);
line_nr := start_line
END
END;
PROCEDURE exp_sel_ass(hpartname_nr:integer);
(* This procedure reads a selective assignment using the grammar : *)
(* *)
(* selective assignment *)
(* : case symbol , part name , of symbol *)
(* , ( selector , colon symbol , attribute assignment LIST *)
(* )CHAIN semicolon symbol *)
(* , ( semicolon symbol , others symbol , colon symbol *)
(* , attribute assignment LIST *)
(* ) OPTION *)
(* , esac symbol *)
(* . *)
(* selector : element LIST . *)
(* *)
(* The selectors are read and tested by the procedure exp_selector. The *)
(* case symbol and the partname have been read. The partname is *)
(* partname is represented by hpartname_nr. *)
VAR
st_of_ass ,
st_of_alt ,
inselfollowers : symbol_set;
FUNCTION exp_sel_alt(previous : elements) : plalt_ass;
(* This procedure reads one alternative of a selective assignment, with *)
(* the grammar : *)
(* *)
(* alternative : (selector ; others symbol) , colon symbol *)
(* , attribute assignments LIST *)
(* . *)
VAR
altass_ptr : plalt_ass;
BEGIN
back_on_the_rails(inpas, st_of_alt, followers,
'starters of alt', m_sal, do_not_skip);
IF scansym IN st_of_alt
THEN (* more alternatives *)
BEGIN
new(altass_ptr);
WITH altass_ptr^ (* = RECORD line_nr : integer; *)
(* other_sel : boolean; *)
(* selectors : elements; *)
(* attr_ass : plattr_ass; *)
(* rest : plalt_ass END *)
DO BEGIN
line_nr := input_line_nr;
IF scansym = others_sym
THEN BEGIN
nextsym(inpas);
other_sel := TRUE;
selectors := [0..max_elem_nr] - previous
END
ELSE BEGIN
other_sel := FALSE;
exp_selectors(selectors, previous,inselfollowers)
END;
back_on_the_rails(inpas, [colon_sym],st_of_ass,
',',m_sex, skip);
attr_ass := exp_list_attr_ass(followers, FALSE, allowedpn,
correctpn);
skip_rubbish(inpas, followers);
IF NOT other_sel
AND (scansym = semicolon_sym)
THEN BEGIN
nextsym(inpas);
rest := exp_sel_alt(previous)
END
ELSE rest := NIL
END;
exp_sel_alt := altass_ptr
END
ELSE exp_sel_alt := NIL
END;
BEGIN (* of exp_sel_ass *)
expect(inpas, of_sym, skip, 'OF');
followers := followers + [esac_sym,semicolon_sym];
st_of_ass := followers + [case_sym,some_sym,of_sym,main_sym,
equal_sym];
st_of_alt := [others_sym,some_sym,comma_sym,colon_sym];
inselfollowers := st_of_ass + [some_sym,comma_sym,colon_sym];
new(result,a_sele);
WITH result^
DO BEGIN
kind := a_sele;
IF topnivo
THEN (* outside any selective assignments *)
BEGIN
allowedpn := undef_partname;
correctpn := FALSE
END;
add_level_info('CASE ' + partname_with(hpartname_nr) + ' OF');
alter := exp_sel_alt([]);
headpnnr := hpartname_nr;
IF alter = NIL
THEN error(w_naa);
IF topnivo
THEN (* outside any selective assignment *)
IF correctpn
THEN headpnnr := nr_of_partname(allowedpn)
ELSE headpnnr := error_part_nr;
back_on_the_rails(inpas, [esac_sym],followers,'ESAC',m_sex, skip);
line_nr := start_line
END
END;
BEGIN (* of exp_list_attr_ass *)
IF scansym IN followers
THEN (* no more attribute assignments *)
exp_list_attr_ass := NIL
ELSE BEGIN
back_on_the_rails(inpas, [case_sym,some_sym,of_sym,main_sym,equal_sym,
comma_sym], followers, 'starters of ass',
m_saa, do_not_skip);
start_line := input_line_nr;
IF scansym IN followers
THEN (* no more attribute assignments *)
exp_list_attr_ass := NIL
ELSE IF scansym = comma_sym
THEN BEGIN
error(s_scm);
nextsym(inpas);
exp_list_attr_ass :=
exp_list_attr_ass(followers,topnivo,allowedpn,correctpn);
END
ELSE BEGIN
enter_level('assignments');
IF scansym = case_sym
THEN (* "CASE" found *)
BEGIN
nextsym(inpas);
exp_sel_ass(nr_of_partname(exp_partname))
END
ELSE IF scansym = some_sym
THEN (* name found *)
BEGIN
IF get_name(nametree, sym, name_ptr)
THEN (* name defined *)
IF name_ptr^.kind = n_attr
THEN hpartname_nr := error_part_nr
ELSE hpartname_nr := nr_of_partname(sym)
ELSE hpartname_nr := nr_of_partname(sym);
hulp_sym := sym;
nextsym(inpas);
IF hpartname_nr = error_part_nr
THEN exp_simp_ass(name_ptr)
ELSE (* partname found *)
exp_sel_ass(hpartname_nr)
END
ELSE (* no name found *)
exp_simp_ass(NIL);
skip_rubbish(inpas,
[comma_sym,case_sym,some_sym]+followers);
IF scansym = comma_sym
THEN nextsym(inpas)
ELSE IF scansym IN [case_sym,some_sym]
THEN error(m_sex, ',');
exit_level;
result^.rest := exp_list_attr_ass(followers,topnivo,
allowedpn,correctpn);
exp_list_attr_ass := result
END
END
END;
|
(* The procedures on this page are for reading and testing the rules, using *)
(* the grammar : *)
(* *)
(* grammar : rules symbol , rule SEQ . *)
(* rule : (tree rule ; class rule) , period symbol . *)
(* *)
(* The following procedures are used for testing and constructing some *)
(* relations between the rules. *)
FUNCTION c_in_clos_c_or_and(class,from_elem:pnode) : boolean;
(* This function tests whether class and from_elem are equal or whether *)
(* class in closure of from_elem. This function is used when testing *)
(* recursive class definitions, which are not allowed. *)
VAR
elemnr : integer;
elems : elements;
found : boolean;
BEGIN
enter_level('test rec classes');
add_level_info('from ' + from_elem^.name);
IF class = from_elem
THEN c_in_clos_c_or_and := TRUE
ELSE WITH from_elem^
DO IF (kind <> n_class) OR (class_rule = [])
THEN c_in_clos_c_or_and := FALSE
ELSE (* from_elem is a class and has a class rule *)
BEGIN
found := FALSE;
elems := class_rule;
elemnr := start_nr;
REPEAT
next_elem(elemnr, elems);
found := c_in_clos_c_or_and(class,element[elemnr])
UNTIL found OR (elems = []);
c_in_clos_c_or_and := found
END;
wait(0.8);
exit_level
END;
PROCEDURE test_consistency(elem_ptr:pnode);
(* This procedure tests whether the tree production is consistent with *)
(* earlier definitions. This is done by propagating a new tree rule along *)
(* the class rules. If at some element two tree productions are defined *)
(* a fatal error message is generated. *)
VAR
elemnr : integer;
class : elements;
tree : ptree_rule;
found : boolean;
BEGIN
enter_level('test consistency');
add_level_info('from ' + elem_ptr^.name);
WITH elem_ptr^
DO IF (class_rule <> []) AND (tree_rule <> NIL)
THEN (* propagate tree rule along class rule *)
BEGIN
class := class_rule;
tree := tree_rule;
elemnr := start_nr;
REPEAT
next_elem(elemnr, class);
WITH element[elemnr]^
DO IF tree_rule <> NIL
THEN (* there is already a tree rule assigned at element *)
IF tree_rule <> tree
THEN (* and it is different, which leads to : *)
error(f_con)
ELSE (* and it is the same, which is allowed *)
ELSE (* no tree rule at element[elemnr] placed yet *)
BEGIN
tree_rule := tree;
kind_of_rule := r_indi;
test_consistency(element[elemnr])
END;
UNTIL class = []
END;
wait(0.8);
exit_level
END;
(* The following procedures are for reading the rules *)
PROCEDURE exp_rule;
(* This procedure reads one tree rule or one class rule, using the grammar: *)
(* *)
(* rule : (class rule ; tree rule) , period symbol . *)
(* class rule *)
(* : class , equal symbol *)
(* , open class symbol , element LIST , close class symbol *)
(* . *)
(* tree rule *)
(* : element , arrow symbol *)
(* , (part name , colon symbol , element)LIST *)
(* , attribute assignments OPTION *)
(* . *)
(* *)
(* This procedure decides what kind of rule there is, and calls one of the *)
(* procedures: exp_tree_rule or exp_class_rule. *)
VAR
elem_ptr : pnode;
starters ,
infollowers : symbol_set;
PROCEDURE exp_tree_rule(elem_ptr:pnode);
(* This procedure reads one tree rule, including the attribute *)
(* assignments. *)
VAR
hulpattr_ass : plattr_ass;
allowedpn : alfa;
correctpn : boolean;
FUNCTION exp_tree_def : ptree_rule;
(* This procedure reads partnames and the element that describe the *)
(* tree rule. It checks whether the partnames are unique and that the *)
(* elements are elements. Is also tested whether this rule, when added, *)
(* causes double tree productions. *)
(* Not more than max_part_nr parts are allowed. If exceeded an error is *)
(* generated. *)
VAR
result ,
lastchain : ptree_rule;
hpartname : alfa;
elem_ptr : pnode;
infollowers : symbol_set;
nr_of_parts : integer; (* number of parts minus 1 *)
PROCEDURE add_at_end; (* of result *)
(* This procedure adds an new part at the end of the definition. *)
PROCEDURE make_new_chain(VAR hulp:ptree_rule);
BEGIN
new(hulp);
WITH hulp^
DO BEGIN
partname := hpartname;
element := elem_ptr;
rest := NIL
END;
lastchain := hulp
END;
BEGIN (* of add at end *)
nr_of_parts := nr_of_parts + 1;
IF nr_of_parts = max_part_nr
THEN (* insertion of the max_part_nr + 1th partname *)
error(i_tmp);
IF result = NIL
THEN make_new_chain(result)
ELSE make_new_chain(lastchain^.rest)
END;
FUNCTION test_partnames(list:ptree_rule):boolean;
(* This functions tests whether the partnames are not used more than *)
(* once, by checking whether the new partname has been used in this *)
(* tree rule before. *)
VAR
result : boolean;
BEGIN
result := TRUE;
WHILE result AND (list <> NIL)
DO BEGIN
result := (list^.partname <> hpartname);
list := list^.rest
END;
test_partnames := result
END;
BEGIN (* of exp_tree_def *)
infollowers := [comma_sym,some_sym,period_sym,open_bracket_sym,
case_sym,of_sym,root_sym];
result := NIL;
skip_rubbish(inpas, infollowers);
nr_of_parts := -1;
WHILE scansym IN [some_sym,colon_sym,comma_sym]
DO BEGIN
IF scansym = some_sym
THEN BEGIN
hpartname := sym;
nextsym(inpas)
END
ELSE BEGIN
error(m_pna);
hpartname.length := 0
END;
back_on_the_rails(inpas, [colon_sym],infollowers, ',', m_sex, skip);
elem_ptr := exp_element;
IF hpartname.length = 0
THEN IF elem_ptr = NIL
THEN (* no partname and no element found *)
error(w_nat)
ELSE (* element without partname found *)
add_at_end
ELSE IF test_partnames(result)
THEN add_at_end
ELSE (* double partname found *)
error(e_dpn);
exp_comma;
skip_rubbish(inpas, infollowers)
END;
exp_tree_def := result
END;
BEGIN (* of exp_tree_rule *)
enter_level('tree rule');
partnames := exp_tree_def;
skip_rubbish(inpas,
[open_bracket_sym,case_sym,some_sym,period_sym,root_sym]);
IF scansym IN [open_bracket_sym,case_sym,some_sym]
THEN (* attribute assignments found *)
BEGIN
expect(inpas, open_bracket_sym, skip, '[');
hulpattr_ass := exp_list_attr_ass
([comma_sym,close_bracket_sym,period_sym,root_sym],
TRUE,allowedpn,correctpn);
back_on_the_rails(inpas, [close_bracket_sym],
[period_sym,root_sym], ']', m_sex,skip)
END
ELSE hulpattr_ass := NIL;
IF elem_ptr = NIL
THEN (* no element for tree rule was found *)
error(w_itl)
ELSE WITH elem_ptr^ (* RECORD tree_rule : ptree_rule; *)
(* kind_of_rule : trule_kind; *)
(* attr_ass : plattr_ass *)
(* END (part of tnode!!) *)
DO IF (kind_of_rule IN [r_undf,r_empt])
AND (attr_ass = NIL)
THEN (* no earlier tree rule at this element *)
BEGIN
IF partnames <> NIL
THEN (* a non-empty tree rule read *)
BEGIN
tree_rule := partnames;
kind_of_rule := r_dire;
END
ELSE (* an empty tree rule read *)
BEGIN
IF hulpattr_ass = NIL
THEN (* also no attribute assignments found *)
error(w_etr);
kind_of_rule := r_empt
END;
(* add tree rule and test consistency: *)
attr_ass := hulpattr_ass;
test_consistency(elem_ptr)
END
ELSE IF kind_of_rule = r_indi
THEN (* indirect tree production at this element *)
BEGIN
tree_rule := partnames;
attr_ass := hulpattr_ass;
error(f_itr);
kind_of_rule := r_dire
END
ELSE (* there has been a tree rule at this element before *)
error(f_rtr);
write_elapsed_time;
exit_level
END;
PROCEDURE exp_class_rule(class_ptr:pnode);
(* This procedure reads a class rule and adds it to the other definitions *)
(* and checks if no double tree productions are generated. The class name,*)
(* the equal symbol and the open class symbol have been read. It is *)
(* tested whether the class name really is defined as a class. If *)
(* not, or the class has already a class rule, the rest of the rule is *)
(* skipped, without checking the syntax. *)
FUNCTION exp_cl_elements : elements;
(* This function reads and tests the elements, defining the class, as a *)
(* list-construct. Warnings are generated when elements appear more *)
(* then once. Elements are not added at the definition, if they cause a *)
(* recursive class definition or when they were already in a class rule.*)
VAR
result : elements;
elem_ptr : pnode;
infollowers : symbol_set;
PROCEDURE add_element_in_class;
(* This procedure adds an element in the set of elements. If it is *)
(* already in another class, or if it will generate a recursive class *)
(* definition, it will not be added and an error message is given. *)
(* a warning is generated if the element was already in the set. *)
VAR
nr : integer;
BEGIN
nr := elem_ptr^.elem_nr;
IF nr <> error_nr
THEN IF nr IN result
THEN error(w_erc)
ELSE IF (elem_ptr^.parent <> []) AND with_orthogonal
THEN error(f_etc)
ELSE IF c_in_clos_c_or_and(class_ptr, elem_ptr)
THEN error(f_rec)
ELSE BEGIN
result := result + [nr];
WITH elem_ptr^
DO parent := parent + [class_ptr^.elem_nr]
END
END;
BEGIN (* of exp_cl_elements *)
infollowers := [comma_sym,some_sym,close_class_sym,period_sym,root_sym];
skip_rubbish(inpas, infollowers);
result := [];
WHILE scansym IN [some_sym,comma_sym]
DO IF scansym = some_sym
THEN BEGIN
elem_ptr := exp_element;
IF elem_ptr <> NIL
THEN add_element_in_class;
exp_comma
END
ELSE sup_comma;
exp_cl_elements := result
END;
BEGIN (* of exp_class_rule *)
enter_level('class rule');
is_class(class_ptr);
IF class_ptr = NIL
THEN (* skip rest of the rule *)
skip_rubbish(inpas, [close_class_sym,period_sym,root_sym])
ELSE WITH class_ptr^
DO IF class_rule = []
THEN (* no class rule defined at this class yet *)
BEGIN
class_rule := exp_cl_elements;
test_consistency(class_ptr)
END
ELSE (* there has been a class rule with this class before *)
BEGIN
error(f_rcr);
skip_rubbish(inpas, [close_class_sym,period_sym,root_sym])
END;
back_on_the_rails(inpas, [close_class_sym],[period_sym,rules_sym,some_sym,
becomes_sym,equal_sym],'}', m_sex, skip);
exit_level
END;
BEGIN (* of exp_rule *)
infollowers := [some_sym,equal_sym,becomes_sym,colon_sym,open_class_sym,
period_sym,open_bracket_sym,case_sym,root_sym];
elem_ptr := exp_element;
skip_rubbish(inpas, infollowers);
IF scansym = equal_sym
THEN (* name "=" found *)
BEGIN
nextsym(inpas);
skip_rubbish(inpas, infollowers);
IF scansym = open_class_sym
THEN (* name "= {" found *)
BEGIN
nextsym(inpas);
exp_class_rule(elem_ptr)
END
ELSE IF test_kind(elem_ptr,n_node)
THEN (* node-name "=" found *)
BEGIN
error(s_arr);
exp_tree_rule(elem_ptr)
END
ELSE (* no-node-name "=" found *)
BEGIN
error(m_sex, '{');
exp_class_rule(elem_ptr)
END
END
ELSE IF scansym = becomes_sym
THEN (* name "=>" found *)
BEGIN
nextsym(inpas);
exp_tree_rule(elem_ptr)
END
ELSE IF scansym = open_class_sym
THEN (* name "{" found *)
BEGIN
error(m_sex, '=');
nextsym(inpas);
exp_class_rule(elem_ptr)
END
ELSE IF test_kind(elem_ptr,n_node)
THEN (* node-name found *)
BEGIN
error(m_sex, '=>');
exp_tree_rule(elem_ptr)
END
ELSE (* nothing that can be recognized as a rule *)
BEGIN
error(s_urr);
skip_rubbish(inpas, [period_sym,root_sym])
END;
back_on_the_rails(inpas,
[period_sym],[root_sym,some_sym,becomes_sym,equal_sym],
'.', m_sex,skip)
END;
PROCEDURE read_rules;
(* This procedure reads the rules from the input. *)
VAR
infollowers : symbol_set;
BEGIN
enter_level('rules');
infollowers := [some_sym,period_sym,becomes_sym,equal_sym,open_class_sym,
root_sym,end_of_file];
back_on_the_rails(inpas, [rules_sym],infollowers,'RULES', s_mk2,skip);
skip_rubbish(inpas, infollowers);
WHILE scansym IN [some_sym,becomes_sym,equal_sym,open_class_sym]
DO BEGIN
exp_rule;
skip_rubbish(inpas, infollowers)
END;
exit_level
END;
PROCEDURE read_root;
(* This procedure reads the root from the input and stores the element in *)
(* the variable root. *)
BEGIN
enter_level('root');
back_on_the_rails(inpas, [root_sym],[],'ROOT', s_mk3,skip);
root := exp_element;
exit_level
END;
|
(* This page has the procedure scanner that reads the entire input, *)
(* according to the grammar : *)
(* *)
(* input grammar *)
(* : (options symbol , options LIST , period symbol)OPTION *)
(* , (classes symbol , class LIST , period symbol)OPTION *)
(* , node types symbol , node type LIST , period symbol *)
(* , (types symbol , type identifier LIST , period symbol)OPTION *)
(* , (functions symbol , semantic function definition SEQ)OPTION *)
(* , attributes symbol , attribute definitions SEQ *)
(* , (input symbol , interface rule SEQ)OPTION *)
(* , (output symbol , interface rule SEQ)OPTION *)
(* , rules symbol , rules SEQ *)
(* , root symbol , element *)
(* . *)
PROCEDURE parser;
BEGIN (* for performance analysis: *)
enter_level('parser');
g_inh_attr := [];
g_syn_attr := [];
g_input_attr := [];
g_output_attr := [];
new(error_ptr); perf_start_time(perf_r_o_c_n);
read_options; write_elapsed_time;
read_classes;
read_node_types; perf_end_time (perf_r_o_c_n);
perf_start_time(perf_r_t_f);
read_types; write_elapsed_time;
read_semantic_functions; perf_end_time (perf_r_t_f);
perf_start_time(perf_r_a_io);
write_elapsed_time;
read_attributes; write_elapsed_time;
read_input_rules;
read_output_rules; perf_end_time (perf_r_a_io);
perf_start_time(perf_r_r_r);
write_elapsed_time;
read_rules;
read_root; write_elapsed_time;
skip_rubbish(inpas, []); perf_end_time (perf_r_r_r);
exit_level
END;
END.
|
In this section we present the complete grammar as being parsed by the procedure parser.
element : class ; node type .
rule : ( class rule ; tree rule ) , . .
class rule : class , = , { , element LIST , } .
tree rule : element , => , (part name , : , element)LIST .
class : identifier .
node type : identifier .
part name : identifier .
attribute definition
: attribute name , : , type identifier
, (synthesized symbol ; inherited symbol)
, OF , element LIST , .
.
attribute name : identifier .
synthesized symbol : SYNTHESIZED ; SYN .
inherited symbol : INHERITED ; INH .
of symbol : OF .
interface rule
: attribute name
, ( AT , element LIST)OPTION , .
.
semantic function definition
: semantic function name
, type identifier LIST PACK
, : , type identifier , .
.
semantic function name : identifier .
tree rule
: element , => , (part name , : , element)LIST
, attribute assignments OPTION
.
attribute assignments
: [ , attribute assignment LIST , ] .
attribute assignment
: attribute occurrence , = , expression
; selective assignment
.
attribute occurrence : attribute name , OF , node name . node name : part name ; # .
semantic function application
: semantic function name
, expression LIST PACK
.
case expression
: CASE , part name , OF
, (selector , : , expression )CHAIN ;
, ( ; , OTHERS , : , expression )OPTION
, ESAC
.
selector : element LIST .
expression
: attribute occurrence
; semantic function application
; case expression
.
selective assignment
: CASE , part name , OF
, ( selector , :
, attribute assignment LIST)CHAIN ;
, ( ; , OTHERS , : , attribute assignment LIST
)OPTION
, ESAC
.
My life as a hacker | My home page