Alexis Ada Reference Manual

--with aada_compiler_token_package;
--with aada_compiler_node_package;
with aada_compiler_error_package;
--with aada_compiler_parser_package;
 
--use aada_compiler_token_package;
--use aada_compiler_node_package;
use aada_compiler_error_package;
--use aada_compiler_parser_package;
 
package body aada_compiler_parser_expression is
 
-- Support for Ada expressions includes the following:
--
-- The break-up shown below is the same as how the expressions are
-- implemented. I made additions to accommodate requirements that
-- are not well defined by the default Ada BNF like rules.
--
-- Note: the Boolean 'true' and 'false' are functions defined in:
-- type Boolean is (false, true);
--
-- expr/terminal:
-- "null"
-- "null record"
-- "<>" [for record_component_association]
-- string [string or named operator]
-- character
-- integer
-- float
-- identifier [name]
-- "(" expr/list ")" [aggregate or grouping]
-- "new" expr/primary [allocator]
--
-- expr/primary:
-- expr/terminal
-- expr/primary "(" expr/list ")" [function, array dereference, slice]
-- expr/primary "." expr/terminal [prefix "." selector_name]
-- expr/primary ".all"
-- expr/primary "'(" expr ")" [qualified expression]
-- expr/primary "'" expr/terminal [attribute_reference]
-- expr/primary "'access" expr/terminal [attribute_reference]
-- expr/primary "'delta" [attribute_reference]
-- expr/primary "'digits" [attribute_reference]
-- expr/primary "'range" [attribute_reference]
-- expr/primary "'range(" expr ")" [attribute_reference]
--
-- expr/factor:
-- expr/primary "**" expr/primary
-- "abs" expr/primary
-- "not" expr/primary
--
-- expr/term:
-- expr/factor "*" expr/factor
-- expr/factor "/" expr/factor
-- expr/factor "mod" expr/factor
-- expr/factor "rem" expr/factor
--
-- expr/simple:
-- "+" expr/term
-- "-" expr/term
-- expr/term "+" expr/term
-- expr/term "-" expr/term
-- expr/term "&" expr/term
--
-- Ranges do not include relations making the "in" and "not in"
-- operators look more logical. see 3.5.4(3) and 4.4(15b)
--
-- expr/range:
-- expr/simple
-- expr/simple ".." expr/simple
--
-- expr/relation:
-- expr/simple
-- expr/simple "=" expr/simple
-- expr/simple "/=" expr/simple
-- expr/simple "<" expr/simple
-- expr/simple "<=" expr/simple
-- expr/simple ">" expr/simple
-- expr/simple ">=" expr/simple
-- expr/simple "in" expr/range
-- expr/simple "not in" expr/range
--
-- expr:
-- expr/relation
-- expr/relation "and" expr/relation
-- expr/relation "and then" expr/relation
-- expr/relation "or" expr/relation
-- expr/relation "or else" expr/relation
-- expr/relation "xor" expr/relation
--
-- lists are not viewed as expression like in C, but it makes sense to read them here
-- since we need to support aggregates that use a list and we also have to support
-- the lists of parameters in function calls
--
-- expr/component_association:
-- expr
-- expr "=>" expr
-- expr "with" expr/list [extension_aggregate]
-- "others =>" expr
-- expr/simple ".." expr/simple [first expression must be simple too!]
--
-- expr/list:
-- expr/component_association
-- expr/component_association "," expr/component_association
 
 
procedure expr_primary(p: in out compiler_parser_type;
                       t: in out compiler_token_type;
                       n: out compiler_node_handle);
 
 
procedure expr_terminal(p: in out compiler_parser_type;
                        t: in out compiler_token_type;
                        n: out compiler_node_handle) is
  token: ada_token;
  c: compiler_node_handle;
begin
  token := get_token_token(t);
 
  case token is
  when token_box | token_string | token_character | token_integer
     | token_float | token_identifier =>
    -- all of those are terminal tokens defined as is
    create_node(n, t);
    next_token(p, t);
 
  when token_null =>
    -- "null" token
    create_node(n, t);
    next_token(p, t);
    token := get_token_token(t);
    if token = token_record then
      -- this is a "null record" token instead
      set_token_token(t, token_null_record);
      init(n, t);
    end if;
 
  when token_open_parenthesis =>
    -- read an expression list and then expect ")"
    create_node(n, t, 1);
    next_token(p, t);
    expression(p, t, c);
    parent(c, n);
    token := get_token_token(t);
    if token /= token_close_parenthesis then
      error(p, expected_close_parenthesis_error, t,
            "expected a "")"" here; or there is a missing operator");
    else
      -- skip the ")"
      next_token(p, t);
    end if;
 
  when token_new =>
    -- followed by a primary expression defining what is allocated
    create_node(n, t, 1);
    next_token(p, t);
    expr_primary(p, t, c);
    parent(c, n);
 
  when others =>
    -- we've got a problem since nothing captured this token!
    -- we leave it alone since it could be a token from after
    -- (i.e. the '*' in "expr '*' expr" where the first expr
    -- is missing.)
    error(p, unexpected_token_in_expression_error, t,
          "unexpected token in an expression");
 
  end case;
end expr_terminal;
 
 
procedure expr_primary(p: in out compiler_parser_type;
                       t: in out compiler_token_type;
                       n: out compiler_node_handle) is
  token: ada_token;
  q: compiler_token_type;
  l, r: compiler_node_handle;
begin
  expr_terminal(p, t, l);
 
  loop
    token := get_token_token(t);
    case token is
    when token_open_parenthesis =>
      -- expr(expr)
      -- note that "call" is a bit "abusive" since this could be
      -- an array dereference and those don't actually generate a 
      -- call per se; it also represets a cast
      set_token_token(t, token_call);
      create_node(n, t);
      parent(l, n);
      next_token(p, t);
      expr_list(p, t, r);
      parent(r, n, 2);
      token := get_token_token(t);
      if token /= token_close_parenthesis then
        error(p, expected_close_parenthesis_error, t,
              "expected a "")"" here; or there is a missing comma");
      else
        -- skip the ")"
        next_token(p, t);
      end if;
 
    when token_period =>
      -- expr.expr
      create_node(n, t, 2);
      parent(l, n);
      next_token(p, t);
      token := get_token_token(t);
      if token = token_all then
        -- special case of expr.all
        -- (we could also create a new node to use only 1 child)
        -- IMPORTANT: now we have a token_all instead of a token_period
        set_token_token(t, token_all);
        init(n, t);
        next_token(p, t);
      else
        expr_primary(p, t, r);
        parent(r, n, 2);
      end if;
 
    when token_apostrophe =>
      -- expr'(expr), expr'expr, expr'access/delta/digits/range[(expr)]
      next_token(p, q);
      token := get_token_token(q);
      case token is
      when token_open_parenthesis =>
        -- expr'(expr)
        -- this is a type qualification
        -- (note that when others => would also be capable of reading this
        -- expression; but it would not automatically mark it as a qualifier)
        set_token_token(t, token_qualify);
        create_node(n, t, 2);
        parent(l, n);
        next_token(p, t);
        expression(p, t, r);
        parent(r, n, 2);
 
      when token_access | token_delta | token_digits | token_range =>
        -- expr'expr
        -- this is a "normal" attribute, it just happen to use a reserved word
        -- the range(expr) is supported by looping (although the loop really
        -- gives use a range(expr/list) but we can check the validity later.)
        create_node(n, t, 2);
        parent(l, n);
        create_node(r, q);
        parent(r, n);
        next_token(p, t);
 
      when others =>
        -- expr'expr
        create_node(n, t, 2);
        parent(l, n);
        -- what can appear after an apostrophy is pretty limited
        expr_terminal(p, t, r);
        parent(r, n, 2);
 
      end case;
 
    when others =>
      n := l;
      return;
 
    end case;
    l := n;
  end loop;
 
end expr_primary;
 
 
-- no loop in factor
procedure expr_factor(p: in out compiler_parser_type;
                      t: in out compiler_token_type;
                      n: out compiler_node_handle) is
  token: ada_token;
  l, r: compiler_node_handle;
begin
  token := get_token_token(t);
  if token = token_abs
  or else token = token_not then
    -- handles abs & not
    create_node(n, t);
    expr_primary(p, t, r);
    parent(r, n);
  else
    expr_primary(p, t, l);
    token := get_token_token(t);
    if token = token_exponential then
      create_node(n, t, 2);
      parent(l, n);
      expr_primary(p, t, r);
      parent(r, n, 2);
    else
      n := l;
    end if;
  end if;
end expr_factor;
 
 
 
procedure expr_term(p: in out compiler_parser_type;
                    t: in out compiler_token_type;
                    n: out compiler_node_handle) is
  token: ada_token;
  l, r: compiler_node_handle;
begin
  expr_factor(p, t, l);
  loop
    token := get_token_token(t);
    case token is
    when token_multiply | token_divide | token_mod | token_rem =>
      -- a simple relation is composed of two terms
      create_node(n, t, 2);
      parent(l, n);
      next_token(p, t);
      expr_factor(p, t, r);
      parent(r, n, 2);
 
    when others =>
      n := l;
      return;
 
    end case;
    l := n;
  end loop;
end expr_term;
 
 
procedure expr_simple(p: in out compiler_parser_type;
                     t: in out compiler_token_type;
                     n: out compiler_node_handle;
                     bin_op_only: in boolean := false) is
  token: ada_token;
  l, r: compiler_node_handle;
begin
  if not bin_op_only then
    token := get_token_token(t);
    if token = token_plus or else token = token_minus then
      -- in this case we are not going to loop
      -- to add a + or - on the right hand, use parenthesis
      if token = token_plus then
        -- IMPORTANT: We cannot optimize the identity here
        --            since that could be a user function
        set_token_token(t, token_identity);
      else
        set_token_token(t, token_negate);
      end if;
      create_node(n, t, 1);
      next_token(p, t);
      expr_simple(p, t, r, true);
      parent(r, n);
      return;
    end if;
  end if;
 
  expr_term(p, t, l);
  loop
    token := get_token_token(t);
    case token is
    when token_plus | token_minus | token_concatenate =>
      -- a simple relation is composed of two terms
      create_node(n, t, 2);
      parent(l, n);
      next_token(p, t);
      expr_term(p, t, r);
      parent(r, n, 2);
 
    when others =>
      n := l;
      return;
 
    end case;
    l := n;
  end loop;
 
end expr_simple;
 
 
procedure expr_range(p: in out compiler_parser_type;
                     t: in out compiler_token_type;
                     n: out compiler_node_handle) is
  token: ada_token;
  l, r: compiler_node_handle;
begin
  -- a range expression doesn't loop
  -- expr .. expr
  expr_simple(p, t, l);
  token := get_token_token(t);
  if token = token_double_dot then
    create_node(n, t, 2);
    parent(l, n);
    next_token(p, t);
    expr_simple(p, t, r);
    parent(r, n, 2);
  else
    n := l;
  end if;
end expr_range;
 
 
-- relations do not loop, use parenthesis if necessary
procedure expr_relation(p: in out compiler_parser_type;
                        t: in out compiler_token_type;
                        n: out compiler_node_handle) is
  token: ada_token;
  q: compiler_token_type;
  l, r, d, e: compiler_node_handle;
  special_token: compiler_token_type;
begin
  expr_simple(p, t, l);
  token := get_token_token(t);
  case token is
  when token_equal | token_inequality | token_less
       | token_less_equal | token_greater | token_greater_equal =>
    -- a simple relation
    create_node(n, t, 2);
    parent(l, n);
    next_token(p, t);
    expr_simple(p, t, r);
    parent(r, n, 2);
 
  when token_in =>
    -- read a range in this case
    create_node(n, t, 2);
    parent(l, n);
    next_token(p, t);
    expr_range(p, t, r);
    parent(r, n, 2);
 
  when token_not =>
    -- here the "not" is expected to be a negation for the "in" keyword
    -- however, it could be that the user forgot to enter the proper
    -- keyword before it, so we do a look ahead
    next_token(p, q);
    token := get_token_token(q);
    if token = token_in then
      -- valid "not in" relation!
      set_token_token(t, token_not_in);
      create_node(n, t, 2);
      parent(l, n);
      next_token(p, t);
      expr_range(p, t, r);
      parent(r, n, 2);
    else
      -- first we read the next expression, if it ends with ".."
      -- then we assume that "in" is missing, otherwise we assume
      -- that one of "and", "or" or "xor" is missing ahead
      special_token := t; -- save t's position info
      create_node(n, t, 2);
      parent(l, n);
      unget_token(p, q);
      expr_simple(p, t, r);
      token := get_token_token(t);
      if token = token_double_dot then
        -- the keyword "in" is missing since we've got a range here
        error(p, expected_in_keyword_error, special_token,
              "expected ""in"" after ""not""");
        create_node(d, t, 2);
        parent(r, d);
        expr_simple(p, t, e);
        parent(e, d, 2);
        parent(d, n, 2);
        set_token_token(special_token, token_not_in);
        init(n, special_token);
      else
        -- TODO:
        -- we need to test whether the expression in 'r' ends with
        -- the "'range" attribute, if so, then we've got a range
        -- and this means the "in" keyword is missing
        error(p, expected_relation_keyword_before_not, special_token,
              "expected ""and"", ""or"","
            & " ""xor"" in front of ""not""");
        parent(r, n, 2);
        -- assume "and" so we can go on with a valid tree
        set_token_token(special_token, token_and);
        init(n, special_token);
      end if;
    end if;
 
  when others =>
    n := l;
    return;
 
  end case;
end expr_relation;
 
procedure expression(p: in out compiler_parser_type;
                     t: in out compiler_token_type;
                     n: out compiler_node_handle) is
  token: ada_token;
  l, r: compiler_node_handle;
begin
  expr_relation(p, t, l);
  loop
    token := get_token_token(t);
    case token is
    when token_and =>
      create_node(n, t, 2);
      next_token(p, t);
      token := get_token_token(t);
      if token = token_then then
        -- change the token type
        set_token_token(t, token_and_then);
        init(n, t);
        next_token(p, t);
      end if;
 
    when token_or =>
      create_node(n, t, 2);
      next_token(p, t);
      token := get_token_token(t);
      if token = token_else then
        -- change the token type
        set_token_token(t, token_or_else);
        init(n, t);
        next_token(p, t);
      end if;
 
    when token_xor =>
      create_node(n, t, 2);
      next_token(p, t);
 
    when others =>
      -- we're done here
      n := l;
      return;
 
    end case;
    parent(l, n);
    expr_relation(p, t, r);
    parent(r, n, 2);
    l := n;
  end loop;
end expression;
 
procedure expr_component_association(p: in out compiler_parser_type;
                                     t: in out compiler_token_type;
                                     n: out compiler_node_handle) is
  token: ada_token;
  a, b: compiler_node_handle;
begin
  token := get_token_token(t);
  if token = token_others then
    -- special case of others => expr
    create_node(n, t);
    next_token(p, t);
    token := get_token_token(t);
    if token = token_arrow then
      next_token(p, t);
    else
      error(p, expected_arrow_error, t,
            "expected ""=>"" after others in a list of expressions");
    end if;
    expression(p, t, a);
    parent(a, n);
    return;
  end if;
 
  expression(p, t, a);
  token := get_token_token(t);
  case token is
  when token_arrow | token_with | token_double_dot =>
    -- expr => expr, expr with expr, expr .. expr
    create_node(n, t, 2);
    parent(a, n);
    next_token(p, t);
    expression(p, t, b);
    parent(b, n, 2);
 
  when others =>
    -- just an expression
    n := a;
 
  end case;
end expr_component_association;
 
procedure expr_list(p: in out compiler_parser_type;
                    t: in out compiler_token_type;
                    n: out compiler_node_handle) is
  token: ada_token;
  a, b: compiler_node_handle;
begin
  -- create a list object with 1 child
  -- the children are then linked together
  set_token_token(t, token_list);
  create_node(n, t, 1);
  expr_component_association(p, t, a);
  parent(a, n);
  loop
    token := get_token_token(t);
    exit when token /= token_comma;
    next_token(p, t);
    expr_component_association(p, t, b);
    next(a, b);
    a := b;
  end loop;
end expr_list;
 
 
end aada_compiler_parser_expression;
 
-- vim: ts=2 sw=2 et syntax=ada