Previous Up Next

The parser module
(parser)

Introduction

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.

1 Parsing the input grammar

The input grammar is described by the following grammar:

The procedure parser reads the input according to the input grammar. This procedure has the following structure:

In the following sections we describe each of the procedures that are called.

2 Parsing options

The procedure read options reads the options according to the following grammar:

3 Parsing enumeration of classes

The procedure read classes reads the enumeration of the classes according to the grammar:

This procedure calls the procedure read names, with the argument n class. The header of this procedure is:

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.

4 Parsing enumeration of node types

The procedure read node types reads the enumeration of the node types according to the grammar:

This procedure calls the procedure read names, with the argument n node.

5 Parsing enumeration of types

The procedure read node types reads the enumeration of the node types according to the grammar:

This procedure calls the procedure read names, with the argument n type.

6 Parsing semantic functions definitions

The procedure read semantic functions reads the enumeration of the function definitions according to the grammar:

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].

7 Parsing attributes definitions

The procedure read attributes reads the enumeration of attribute definitions according to the following grammar:

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].

8 Parsing input/output attribute declarations

The procedures read input rules and read output rules reads the input and the output rules according to the following grammar:

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].

9 Parsing tree rules and class definitions

The procedure read rules reads the grammar rules according to the grammar:

This procedure calls the procedure exp rule, which reads one grammar rule according to the grammar:

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.

9.1 Reading class definitions

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.

9.2 Reading tree rules

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.

9.3 Testing consistency

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.

10 Parsing attribute assignments

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:

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.

10.1 Reading a simple assignment

The procedure exp simp ass reads a simple attribute assignment according to the following grammar:

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

10.2 Reading a selective assignment

The procedure exp sel ass reads a selective assignment according to the following grammar:

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:

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

11 Parsing expressions

The function exp expression of type pexpr returns the expression read by the function according to the following grammar:

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.

11.1 Reading a simple expression

The function exp simple expr of type pexpr returns the representation of an attribute occurrence, according to the following grammar:

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].

11.2 Reading a semantic function expression

The function exp sem func expr of type pexpr returns the representation of a semantic function application, according to the following grammar:

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.

11.3 Reading a case expression

The function exp case expr of type pexpr returns the representation of a case expression according to the following grammar:

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:

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.

12 Parsing selection constructions

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:

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.

13 Parsing an element

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.

13.1 Test element is class

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.

14 Parsing a type

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.

15 Parsing an attribute

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.

15.1 Testing inherited or synthesized

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.

15.2 Testing applied or used

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.

16 Parsing and processing part names

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.

16.1 Reading an alphabetic representation of a part name

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.

16.2 Converting an alphabetic representation into a number

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.

16.3 Reading a partname and returning its number

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.

16.4 Converting a number into an alphabetic representation

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.

17 Parsing root element

The procedure read root reads the root element identifier and stores it in the global variable root [bintree 2.2].

18 Interface

This module uses declarations from the following modules:

18.1 Exported constants

The following constant declarations are exported:

18.2 Exported procedure

This module only exports the following procedure:

19 The listing

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.

19.1 Typing

19.1.1 Environment and inherited modules

[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.                *)

19.1.2 Constant declarations

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;

19.1.3 Variable declarations

VAR
(* local for this program                                                     *)
  error_ptr     : [HIDDEN] pnode;    (* used when reading double definitions  *)
  partnames     : [HIDDEN] ptree_rule; (* holding last read tree rule         *)

19.1.4 Procedure declarations

  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;

19.2 Parsing options

(*  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;

19.3 Parsing elements

(*  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;

19.4 Parsing types

(*  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;

19.5 Reading semantic function declarations

(*  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;

19.6 Parsing attribute declarations

(*  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;

19.7 Parsing input/output declarations

(*  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;

19.8 Parsing partnames

(*  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;

19.9 Parsing selectors

(*  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;

19.10 Parsing expressions

(*  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;

19.11 Parsing attribute assignments

(*  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;

19.12 Parsing tree rules and class definitions

(*  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;

19.13 Parsing the whole input

(*  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.

20 Input grammar

In this section we present the complete grammar as being parsed by the procedure parser.


My life as a hacker | My home page