Alexis Ada Reference Manual

with aada_character_categories;
with aada_compiler_ucs4_character;
with aada_text_input_package;
with aada_compiler_character_package;
with aada_compiler_token_position;
with aada_vstrings;
 
use aada_character_categories;
use aada_compiler_ucs4_character;
use aada_compiler_character_package;
use aada_compiler_token_position;
use aada_vstrings;
 
package body aada_compiler_token_package is
 
-- open the input text file
procedure open(f: in out compiler_token_input_type; name: in string) is
begin
  aada_text_input_package.open(f.file_input, name);
  -- reset the look ahead stack (mark it empty)
  f.look_ahead.token := token_nil;
end open;
 
procedure close(f: in out compiler_token_input_type) is
begin
  aada_text_input_package.close(f.file_input);
end close;
 
function is_open(f: in compiler_token_input_type) return boolean is
begin
  return aada_text_input_package.is_open(f.file_input);
end is_open;
 
function name(f: in compiler_token_input_type) return string is
begin
  return aada_text_input_package.name(f.file_input);
end name;
 
procedure get_character(f: in out compiler_token_input_type;
                        ct: out compiler_token_character) is
  status: character_status;
  code: ucs4_character;
  position: page_sizes_type;
  last_page: position_type;
begin
  -- called unget_character()?
  if f.stack.pointer /= stack_pointer_type'first then
    -- restore the character including its position
    ct := f.stack.stack(f.stack.pointer);
    return;
  end if;
 
  -- the character being read has this very position
  ct.position := f.current_position;
 
  if f.unget /= 16#0A# then
    set_ucs4_character(ct.c, f.unget);
    f.unget := 16#0A#;
  else
    aada_text_input_package.get(f.file_input, ct.c);
  end if;
  if aada_compiler_character_package.eof(ct.c) then
    -- get_ucs4_code() would raise an error otherwise
    return;
  end if;
 
  -- check whether we reached the end of the line or page
  code := get_ucs4_code(ct.c);
  case code is
  when 16#0D# => -- CR
    -- we do not need to increase char_pos in this case since
    -- we are about to reset it back to 1 anyway
    aada_text_input_package.get(f.file_input, ct.c);
    status := get_status(ct.c);
    if status /= aada_compiler_character_package.eof then
      code := get_ucs4_code(ct.c);
      if code /= 16#0A# then -- not LF? (i.e. for CR LF => 1 line)
        -- save for next call to get_character()
        f.unget := code;
      end if;
    end if;
    get_special_character(ct.c, eol);
    next_line(f.page_sizes, f.current_position);
 
  when 16#000A#    -- LF
     | 16#2028#    -- line separator
     | 16#2029# => -- paragraph separator (this has the same effect as eol)
    get_special_character(ct.c, eol);
    next_line(f.page_sizes, f.current_position);
 
  when 16#0085# | 16#000C# => -- NEL | LF
    -- we should create an EOP but we don't need that distinction
    -- anywhere else so we simplify the code with EOL
    get_special_character(ct.c, eol);
    -- if immediately followed by CR, LF or CR+LF, remove
    aada_text_input_package.get(f.file_input, ct.c);
    status := get_status(ct.c);
    if status /= aada_compiler_character_package.eof then
      code := get_ucs4_code(ct.c);
      if code = 16#0D# then -- CR
        aada_text_input_package.get(f.file_input, ct.c);
        status := get_status(ct.c);
        if status /= aada_compiler_character_package.eof then
          code := get_ucs4_code(ct.c);
          if code /= 16#0A# then -- CR+LF?
            f.unget := code;
          end if;
          -- make sure we enter the LF condition below
          code := 16#0A#;
        end if;
      end if;
      if code = 16#0A# then -- LF
        -- count the line now so we don't start a new page with a new line
        last_page := get_position(f.current_position, page);
        next_line(f.page_sizes, f.current_position);
        if last_page /= get_position(f.current_position, page) then
          -- the next_line() added a page already,
          -- so we don't add it again
          return;
        end if;
      else
        f.unget := code;
      end if;
    end if;
    next_page(f.page_sizes, f.current_position);
 
  when 16#0B# => -- VT
    -- vertical tab
    get_special_character(ct.c, eol);
    next_line(f.page_sizes, f.current_position,
                                      get_size(f.page_sizes, vertical_tab));
 
  when 16#09# => -- HT
    -- horizontal tab
    next_character(f.page_sizes, f.current_position,
                                      get_size(f.page_sizes, horizontal_tab));
    -- transform in a Space so we don't have to handle HT separately
    set_ucs4_character(ct.c, 16#20#);
 
  when others =>
    -- non-formatting characters are counted as one
    -- (of course... next_character() may add a line which in
    -- turn may add a page)
    -- XXX: should characters such as 0xFEFF not be counted?
    next_character(f.page_sizes, f.current_position);
 
  end case;
end get_character;
 
procedure unget_character(f: in out compiler_token_input_type;
                          ct: in compiler_token_character) is
begin
  if f.stack.pointer = stack_pointer_type'last then
    raise unget_stack_is_full_error;
  end if;
  -- save the character including its position
  f.stack.pointer := stack_pointer_type'succ(f.stack.pointer);
  f.stack.stack(f.stack.pointer) := ct;
end unget_character;
 
procedure set_token(f: in out compiler_token_input_type;
                    t: in ada_token;
                    c: in compiler_character) is
begin
  -- f.position := ... already set
  f.token.token := t; -- token
  f.token.operator := token_unknown;
 
  if t = token_eof or t = token_nil then
    f.literal_size := 0; -- this is a special case for EOF, EOL, etc.
    -- the literal is empty
  else
    -- start with a length of 1
    -- use the add_to_token() to add more characters
    f.literal_size := 1;
 
    -- copy the 1 character "string"
    f.literal(integer(f.literal'first)) := c;
  end if;
end set_token;
 
-- helper function that transforms a UCS4 character in a compiler character
procedure set_token(f: in out compiler_token_input_type;
                    t: in ada_token;
                    u: in ucs4_character) is
  c: compiler_character;
begin
  set_ucs4_character(c, u);
  set_token(f, t, c);
end set_token;
 
procedure add_to_token(f: in out compiler_token_input_type;
                       c: in compiler_character) is
begin
  if f.literal_size >= compiler_literal_index'last then
    -- this literal is too large, we cannot save more characters
    raise literal_too_long_error;
  end if;
  f.literal_size := compiler_literal_index'succ(f.literal_size);
  f.literal(integer(f.literal_size)) := c;
end add_to_token;
 
procedure add_to_token(f: in out compiler_token_input_type;
                       u: in ucs4_character) is
  c: compiler_character;
begin
  set_ucs4_character(c, u);
  add_to_token(f, c);
end add_to_token;
 
function decimal_token_to_integer(f: in compiler_token_input_type)
                                                      return integer is
  r: integer := 0;
  c: compiler_character;
  code: ucs4_character;
begin
  -- this function should never be called if the literal is empty
  if f.literal_size = 0 then
    raise program_error;
  end if;
  -- compute the value, note that the literal is a compiler_character_string
  -- which means we need to get the ucs4_character for each character...
  for i in compiler_literal_index
             range compiler_literal_index(f.literal'first) .. f.literal_size
  loop
    c := f.literal(integer(i));
    code := get_ucs4_code(c);
    r := r * 10 + integer(code - 16#30#);
  end loop;
  return r;
end decimal_token_to_integer;
 
function is_digit(code: in ucs4_character;
                  base: in numeral_base_type) return boolean is
begin
  -- smaller bases means less digits are allowed
  if base <= 10 then
    return code in 16#30# .. ucs4_character(16#30# + base - 1);
  end if;
 
  -- regular digits
  if code in 16#30# .. 16#39# then
    return true;
  end if;
 
  -- extended digits
  return code in 16#41# .. ucs4_character(16#41# + base - 11)   -- uppercase
      or code in 16#61# .. ucs4_character(16#61# + base - 11);  -- lowercase
end is_digit;
 
procedure get_numeral(f: in out compiler_token_input_type;
                      ct: out compiler_token_character;
                      code: out ucs4_character;
                      base: in numeral_base_type) is
  last_was_underscore: boolean;
  status: character_status;
begin
  last_was_underscore := false;
  loop
    get_character(f, ct);
    status := get_status(ct.c);
    case status is
    when aada_compiler_character_package.eol
       | aada_compiler_character_package.eof => -- skip those
      -- there is nothing more we can do here on this one
      code := 16#FFFF#; -- represents EOF/EOL here
 
    when aada_compiler_character_package.valid
       | aada_compiler_character_package.unnormalized =>
      -- check the character
      code := get_ucs4_code(ct.c);
      if code = 16#5F# then -- '_'
        if last_was_underscore then
          -- two underscores in a row is not legal
          aada_compiler_error_package.error(f.compiler_error,
              aada_compiler_error_package.two_underscores_error,
              ct.position,
              "found two underscores in a row in a numeral");
        end if;
        last_was_underscore := true;
      else
        -- check whether code is a valid digit (according to 'base')
        -- '0' .. '9' | 'A' .. 'Z' | 'a' .. 'z'
        exit when not is_digit(code, base);
 
        -- append the next digit
        add_to_token(f, ct.c);
        last_was_underscore := false;
      end if;
 
    when others => -- should never happen (character package raised an error!)
      raise program_error;
 
    end case;
  end loop;
 
  -- verify that we did not end with an underscore
  if last_was_underscore then
    aada_compiler_error_package.error(f.compiler_error,
        aada_compiler_error_package.invalid_underscore_error,
        ct.position,
        "found an illegal underscore at the end of a numeral");
    last_was_underscore := false;
  end if;
end get_numeral;
 
procedure get_number(f: in out compiler_token_input_type;
                     code: in ucs4_character) is
  base: numeral_base_type := 10;
  int_base: integer;
  ct, ct2: compiler_token_character;
  status: character_status;
  subcode: ucs4_character;
begin
  -- case when a period was found first?
  if code = 16#2E# then
    -- prepend a zero before the period
    set_token(f, token_float, 16#30#);
    add_to_token(f, 16#2E#);
    subcode := code;
  else
    -- this is a number, we first read all the digits [0-9_]+
    -- and thus assume it is an integer
    set_token(f, token_integer, code);
    get_numeral(f, ct, subcode, 10);
    if subcode = 16#FFFF# then
      -- found an EOL or an EOF
      return;
    end if;
 
    -- check for a base indicated (#)
    if subcode = 16#23# then -- '#'
      int_base := decimal_token_to_integer(f);
      if int_base not in integer(numeral_base_type'first)
                      .. integer(numeral_base_type'last) then
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.unacceptable_numeric_base_error,
            ct.position,
            "unacceptable base for a numeric");
        -- use a default that should take us through the following
        -- loop albeit with the wrong value
        int_base := 36;
      end if;
      base := numeral_base_type(int_base);
      get_character(f, ct2);
      status := get_status(ct2.c);
      case status is
      when aada_compiler_character_package.eol
         | aada_compiler_character_package.eof => -- skip those
        -- the number is invalid
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.invalid_based_number_error,
            ct2.position,
            "based numeral missing digits after the # character");
        return;
 
      when aada_compiler_character_package.valid
         | aada_compiler_character_package.unnormalized =>
        -- check the character
        subcode := get_ucs4_code(ct2.c);
        if subcode = 16#5F# then -- '_'
          -- start underscores not allowed
          aada_compiler_error_package.error(f.compiler_error,
              aada_compiler_error_package.invalid_underscore_error,
              ct2.position,
              "underscore right at the beginning of a based number");
          get_numeral(f, ct, subcode, base);
        elsif subcode = 16#2E# then
          -- this is a floating point
          f.token.token := token_float;
          -- in case the user missed the 0 before the decimal point
          aada_compiler_error_package.error(f.compiler_error,
              aada_compiler_error_package.invalid_floating_point_error,
              ct2.position,
              "floating point starting with the decimal point");
          add_to_token(f, ct.c); -- '#'
          set_ucs4_character(ct.c, 16#30#); -- '0'
          add_to_token(f, ct.c); -- '0'
          add_to_token(f, ct2.c); -- '.'
          get_numeral(f, ct, subcode, base);
        elsif not is_digit(subcode, base) then
          case subcode is
          when 16#30# .. 16#39# | 16#41# .. 16#5A# | 16#61# .. 16#7A# =>
            -- error about digit being out of bound
            aada_compiler_error_package.error(f.compiler_error,
                aada_compiler_error_package.invalid_floating_point_error,
                ct2.position,
                "digit '" & character'val(subcode) & "' out of range for base "
              & numeral_base_type'image(base));
 
          when others =>
            -- error about invalid character inside the #...# bounds
            aada_compiler_error_package.error(f.compiler_error,
                aada_compiler_error_package.invalid_floating_point_error,
                ct2.position,
                "found a non-digit character inside a based numeral");
 
          end case;
          unget_character(f, ct2);
          return;
        else -- '0' .. '9', 'A' .. 'Z', 'a' .. 'z', limited by base
          add_to_token(f, ct.c);
          add_to_token(f, ct2.c);
          get_numeral(f, ct, subcode, base);
 
          -- test whether this is followed by a decimal point
          status := get_status(ct.c);
          case status is
          when aada_compiler_character_package.valid
             | aada_compiler_character_package.unnormalized =>
            -- check the next character for '#'
            subcode := get_ucs4_code(ct.c);
            if subcode = 16#2E# then -- '.'
              -- this is a floating point
              f.token.token := token_float;
              get_character(f, ct);
              status := get_status(ct2.c);
              case status is
              when aada_compiler_character_package.eol
                 | aada_compiler_character_package.eof => -- skip those
                -- the floating point is not valid
                aada_compiler_error_package.error(f.compiler_error,
                    aada_compiler_error_package.invalid_based_number_error,
                    ct2.position,
                    "based floating point must have at least one digit after"
                  & "the decimal point and end with #");
                -- unget_character(f, ct); -- period part of decimal number
                return;
 
              when aada_compiler_character_package.valid
                 | aada_compiler_character_package.unnormalized =>
                -- check the character
                subcode := get_ucs4_code(ct2.c);
                if subcode = 16#2E# then
                  -- okay, then we assume that this is a missing '#'!
                  f.token.token := token_integer;
                  unget_character(f, ct); -- '.'
                  unget_character(f, ct2); -- '.'
                  return;
                elsif is_digit(subcode, base) then
                  add_to_token(f, ct.c); -- '.'
                  add_to_token(f, ct2.c); -- extended digit
                  get_numeral(f, ct, subcode, base);
                else
                  -- invalid digit for this based number
                  case subcode is
                  when 16#30# .. 16#39# | 16#41# .. 16#5A# | 16#61# .. 16#7A# =>
                    -- error about digit being out of bound
                    aada_compiler_error_package.error(f.compiler_error,
                        aada_compiler_error_package.invalid_floating_point_error,
                        ct2.position,
                        "digit '" & character'val(subcode)
                      & "' out of range for base "
                      & numeral_base_type'image(base));
 
                  when others =>
                    -- error about invalid character inside the #...# bounds
                    aada_compiler_error_package.error(f.compiler_error,
                        aada_compiler_error_package.invalid_floating_point_error,
                        ct2.position,
                        "found a non-digit character inside a based numeral");
 
                  end case;
                  unget_character(f, ct2);
                  return;
                end if;
 
              when others => -- should never happen
                raise program_error;
 
              end case;
            else
              aada_compiler_error_package.error(f.compiler_error,
                  aada_compiler_error_package.invalid_based_number_error,
                  ct.position,
                  "based numbers must end with #");
            end if;
 
          when others =>
            -- do nothing here, the following code handles these errors
            null;
 
          end case;
        end if;
 
      when others => -- should never happen
        raise program_error;
 
      end case;
 
      -- test for '#'
      status := get_status(ct.c);
      case status is
      when aada_compiler_character_package.eol
         | aada_compiler_character_package.eof => -- skip those
        -- the number is invalid, missing '#'
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.invalid_based_number_error,
            ct.position,
            "based numbers must end with #");
        return;
 
      when aada_compiler_character_package.valid
         | aada_compiler_character_package.unnormalized =>
        -- check the next character for '#'
        subcode := get_ucs4_code(ct.c);
        if subcode = 16#23# then -- '#'
          -- skip the '#' and see whether we have an 'E'xponent
          -- also avoid taking '.' as a decimal point
          get_character(f, ct);
          status := get_status(ct.c);
          case status is
          when aada_compiler_character_package.eol
             | aada_compiler_character_package.eof => -- skip those
            -- the number is valid, there is no exponent
            return;
 
          when aada_compiler_character_package.valid
             | aada_compiler_character_package.unnormalized =>
            -- check the character
            subcode := get_ucs4_code(ct.c);
            if subcode = 16#2E# then
              -- this number may be valid, but it is followed by a
              -- decimal point which is going to cause problems
              -- unless it is a double dot
              unget_character(f, ct);
              return;
            end if;
            -- FALLTHROUGH -- we allow the exponent now
 
          when others => -- should never happen
            raise program_error;
 
          end case;
        else
          aada_compiler_error_package.error(f.compiler_error,
              aada_compiler_error_package.invalid_based_number_error,
              ct.position,
              "based numbers must end with #");
        end if;
 
      when others => -- should never happen
        raise program_error;
 
      end case;
      -- FALLTHROUGH to get the exponent if there is one
    end if;
  end if;
 
  -- check for a decimal point
  if subcode = 16#2E# then -- '.'
    -- this is a floating point
    f.token.token := token_float;
    -- we don't overwrite ct since we may need it
    get_character(f, ct2);
    status := get_status(ct2.c);
    case status is
    when aada_compiler_character_package.eol
       | aada_compiler_character_package.eof => -- skip those
      -- the number is invalid
      aada_compiler_error_package.error(f.compiler_error,
          aada_compiler_error_package.invalid_floating_point_error,
          ct2.position,
          "floating point missing digits after the decimal point");
      return;
 
    when aada_compiler_character_package.valid
       | aada_compiler_character_package.unnormalized =>
      -- check the character
      subcode := get_ucs4_code(ct2.c);
      if subcode = 16#5F# then -- '_'
        -- an underscores right after the decimal pointer is not legal
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.invalid_underscore_error,
            ct2.position,
            "found an underscore right after a decimal point");
        get_numeral(f, ct, subcode, 10);
      elsif subcode = 16#2E# then
        -- special case of a double dot right after an integer
        unget_character(f, ct2); -- '.'
        unget_character(f, ct); -- '.'
        return;
      elsif subcode = 16#45# or subcode = 16#65# then -- 'E' or 'e'
        -- this is taken as the exponent character although it is not
        -- legal here without at least one digit
        -- (note: Ada does not accept 123.func() so we're good)
        -- XXX: check next character for +, - or a digit?
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.invalid_floating_point_error,
            ct2.position,
            "you need at least one digit after the decimal point"
          & " and before the exponent");
        -- continue to next part
      elsif subcode not in 16#30# .. 16#39# then
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.invalid_floating_point_error,
            ct2.position,
            "floating point without digits after the decimal point");
        return;
      else -- '0' .. '9', we can read a numeral
        add_to_token(f, ct.c); -- '.'
        add_to_token(f, ct2.c); -- '0' .. '9'
        get_numeral(f, ct, subcode, 10);
      end if;
 
    when others => -- should never happen
      raise program_error;
 
    end case;
  end if;
 
  -- see whether there is an exponent
  if subcode = 16#45# or subcode = 16#65# then -- 'E' or 'e'
    -- we don't overwrite ct since we may need it
    get_character(f, ct2);
    status := get_status(ct2.c);
    case status is
    when aada_compiler_character_package.eol
       | aada_compiler_character_package.eof => -- skip those
      -- the number is invalid
      -- as far as I can tell it is not possible to have a number followed by
      -- the letter 'e' and not view that letter as part of the number; however
      -- we may want to restore the 'e'? (in case the user missed typing an
      -- operator) [unless the exponent is on the next line?!]
      -- i.e. 34.0*e was written 34.0e (oops)
      aada_compiler_error_package.error(f.compiler_error,
          aada_compiler_error_package.invalid_exponent_error,
          ct2.position,
          "invalid number followed by an E and no exponent or missing operator");
      -- unget_character(f, ct)?
      return;
 
    when aada_compiler_character_package.valid
       | aada_compiler_character_package.unnormalized =>
      -- check the character
      subcode := get_ucs4_code(ct2.c);
      if subcode = 16#5F# then -- '_'
        -- an underscore right after the decimal pointer is not legal
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.invalid_underscore_error,
            ct2.position,
            "found an underscore right after an exponent mark (E or e)");
        add_to_token(f, ct.c);
        get_numeral(f, ct, subcode, 10);
      elsif subcode = 16#2B# or subcode = 16#2D# then
        -- + or - included, get the first digit
        add_to_token(f, ct.c);
        if subcode = 16#2D# then
          -- keep the -, forget the + altogether
          add_to_token(f, ct2.c);
        end if;
        -- get another character
        get_character(f, ct);
        status := get_status(ct.c);
        case status is
        when aada_compiler_character_package.eol
           | aada_compiler_character_package.eof => -- skip those
          -- the number is definitively invalid
          aada_compiler_error_package.error(f.compiler_error,
              aada_compiler_error_package.invalid_exponent_error,
              ct.position,
              "number followed by an E+ or E- and no exponent");
          -- restore the sign in case it was the operator?
          -- in this case it is more likely that the E was for Exponent
          -- unget_character(f, ct2);
          return;
 
        when aada_compiler_character_package.valid
           | aada_compiler_character_package.unnormalized =>
          -- check the character
          subcode := get_ucs4_code(ct.c);
          if subcode = 16#5F# then -- '_'
            -- an underscore right after the decimal pointer is not legal
            aada_compiler_error_package.error(f.compiler_error,
                aada_compiler_error_package.invalid_underscore_error,
                ct.position,
               "found an underscore right after an exponent sign (E+_ or E-_)");
            get_numeral(f, ct, subcode, 10);
          elsif subcode in 16#30# .. 16#39# then
            -- '0' .. '9', we can read a numeral
            get_numeral(f, ct, subcode, 10);
          else
            -- the number is invalid
            aada_compiler_error_package.error(f.compiler_error,
                aada_compiler_error_package.invalid_exponent_error,
                ct.position,
                "number followed by an E+ or E- and no exponent");
            -- whatever is coming up we restore it and return
            unget_character(f, ct);
            return;
          end if;
 
        when others => -- should never happen
          raise program_error;
 
        end case;
      elsif subcode in 16#30# .. 16#39# then
        -- '0' .. '9', we can read a numeral
        add_to_token(f, ct.c);
        add_to_token(f, ct2.c);
        get_numeral(f, ct, subcode, 10);
      end if;
      -- restore the look ahead, including the 'e' if there wasn't a valid
      -- number after it
      unget_character(f, ct);
    when others => -- should never happen
      raise program_error;
 
    end case;
  else
    unget_character(f, ct);
  end if;
end get_number;
 
procedure identifier_to_reserved_word(f: in out compiler_token_input_type;
                                      ascii_token: in boolean) is
  type token_list_item is
    record
      length: positive;
      word: string(1 .. 12);
    end record;
  type token_list is array(token_abort .. token_xor) of token_list_item;
  -- only latin letter currently not used in a token is J
  tokens: constant token_list := (
    token_abort        => ( 5, "ABORT       "),
    token_abs          => ( 3, "ABS         "),
    token_abstract     => ( 8, "ABSTRACT    "),
    token_accept       => ( 6, "ACCEPT      "),
    token_access       => ( 6, "ACCESS      "),
    token_aliased      => ( 7, "ALIASED     "),
    token_all          => ( 3, "ALL         "),
    token_and          => ( 3, "AND         "),
    token_array        => ( 5, "ARRAY       "),
    token_at           => ( 2, "AT          "),
    token_begin        => ( 5, "BEGIN       "),
    token_body         => ( 4, "BODY        "),
    token_case         => ( 4, "CASE        "),
    token_constant     => ( 8, "CONSTANT    "),
    token_declare      => ( 7, "DECLARE     "),
    token_delay        => ( 5, "DELAY       "),
    token_delta        => ( 5, "DELTA       "),
    token_digits       => ( 6, "DIGITS      "),
    token_do           => ( 2, "DO          "),
    token_else         => ( 4, "ELSE        "),
    token_elsif        => ( 5, "ELSIF       "),
    token_end          => ( 3, "END         "),
    token_entry        => ( 5, "ENTRY       "),
    token_exception    => ( 9, "EXCEPTION   "),
    token_exit         => ( 4, "EXIT        "),
    token_for          => ( 3, "FOR         "),
    token_function     => ( 8, "FUNCTION    "),
    token_generic      => ( 7, "GENERIC     "),
    token_goto         => ( 4, "GOTO        "),
    token_if           => ( 2, "IF          "),
    token_in           => ( 2, "IN          "),
    token_interface    => ( 9, "INTERFACE   "),
    token_is           => ( 2, "IS          "),
    token_limited      => ( 7, "LIMITED     "),
    token_loop         => ( 4, "LOOP        "),
    token_mod          => ( 3, "MOD         "),
    token_new          => ( 3, "NEW         "),
    token_not          => ( 3, "NOT         "),
    token_null         => ( 4, "NULL        "),
    token_of           => ( 2, "OF          "),
    token_or           => ( 2, "OR          "),
    token_others       => ( 6, "OTHERS      "),
    token_out          => ( 3, "OUT         "),
    token_overriding   => (10, "OVERRIDING  "),
    token_package      => ( 6, "PACKAGE     "),
    token_pragma       => ( 6, "PRAGMA      "),
    token_private      => ( 7, "PRIVATE     "),
    token_procedure    => ( 9, "PROCEDURE   "),
    token_protected    => ( 9, "PROTECTED   "),
    token_raise        => ( 5, "RAISE       "),
    token_range        => ( 5, "RANGE       "),
    token_record       => ( 6, "RECORD      "),
    token_rem          => ( 3, "REM         "),
    token_renames      => ( 7, "RENAMES     "),
    token_requeue      => ( 7, "REQUEUE     "),
    token_return       => ( 6, "RETURN      "),
    token_reverse      => ( 7, "REVERSE     "),
    token_select       => ( 6, "SELECT      "),
    token_separate     => ( 8, "SEPARATE    "),
    token_subtype      => ( 7, "SUBTYPE     "),
    token_synchronized => (12, "SYNCHRONIZED"),
    token_tagged       => ( 6, "TAGGED      "),
    token_task         => ( 4, "TASK        "),
    token_terminate    => ( 9, "TERMINATE   "),
    token_then         => ( 4, "THEN        "),
    token_type         => ( 4, "TYPE        "),
    token_until        => ( 5, "UNTIL       "),
    token_use          => ( 3, "USE         "),
    token_when         => ( 4, "WHEN        "),
    token_while        => ( 5, "WHILE       "),
    token_with         => ( 4, "WITH        "),
    token_xor          => ( 3, "XOR         ")
  );
  ch: character;
  l: natural;
begin
  -- get the uppercase version (necessary to compare two identifiers
  -- so we cache it in the token)
  get_uppercase(f.literal(integer(f.literal'first) .. integer(f.literal_size)),
                f.token.uppercase);
 
  -- get the string and check the size
  l := aada_vstrings.length(f.token.uppercase);
  if l < 2 or else l > 12 then
    -- longest reserved word is SYNCHRONIZED (12 chars)
    -- smallests (AT, DO, IF, IN, IS, OF, OR) are 2
    -- too small or large to be a token, return immediately
    return;
  end if;
 
  -- check each character; if not ASCII, return immediately
  -- (this is partially a left over since before I would copy the string)
  for i in positive range 1 .. l
  loop
    ch := aada_vstrings.get(f.token.uppercase, i);
    if ch not in 'A' .. 'Z' or else ch = 'J' then
      -- 'J' is not currently used by any reserved keyword!
      --
      -- ignore any identifier that is not exclusively composed
      -- of ASCII letters as expected in a keyword
      return;
    end if;
  end loop;
 
  -- check whether this is a reserved word
  -- TODO: use a binary search! (we can easily check just the 1st char.)
  for j in token_list'range
  loop
    if l = tokens(j).length
    and then aada_vstrings.str(f.token.uppercase) = tokens(j).word then
      if not ascii_token then
        -- this is not a valid reserved keyword
        -- (i.e. ACCESS with a lowercase German Sharp S or "Szet")
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.illegal_identifier_error,
            f.token.position,
            "identifier """ & aada_vstrings.str(f.token.uppercase)
          & """ matches a reserved word but is not exclusively composed"
          & " of the letters A to Z, it is considered illegal.");
        -- keep it as an identifier and return
      else
        -- valid reserved word!
        f.token.token := j;
      end if;
      return;
    end if;
  end loop;
end identifier_to_reserved_word;
 
procedure get_token_literal(f: in out compiler_token_input_type) is
  status: character_status;
  ct, ct2: compiler_token_character;
  code: ucs4_character;
  category: character_category;
  last_character_category: character_category;
  ascii_token: boolean;
begin
  loop
    f.literal_size := 0;
    get_character(f, ct);
    f.token.position := ct.position;
    status := get_status(ct.c);
    case status is
    when aada_compiler_character_package.eol => -- skip those
      null;
 
    when aada_compiler_character_package.eof => -- we're done here
      -- the character is ignored in this call
      set_token(f, token_eof, ct.c);
      return;
 
    when aada_compiler_character_package.valid
       | aada_compiler_character_package.unnormalized =>
      code := get_ucs4_code(ct.c);
      case code is
      when 16#01# .. 16#1F# -- SOH to US
         | 16#80# .. 16#9F# -- Reserved_128 to APC
        =>
        -- generate an error about controls and go on
        -- (note that controls that we must handle were
        -- handled in the get_character() call)
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.unexpected_character_error,
            ct.position,
            "illegal control character in input stream");
 
      when 16#0020# -- space
         | 16#00A0# -- no-break space
         | 16#1680# -- ogham space mark
         | 16#180E# -- mongolian vowel separator
         | 16#2000# -- en quad
         | 16#2001# -- em quad
         | 16#2002# -- en space
         | 16#2003# -- em space
         | 16#2004# -- three-per-em space
         | 16#2005# -- four-per-em space
         | 16#2006# -- six-per-em space
         | 16#2007# -- figure space
         | 16#2008# -- punctuation space
         | 16#2009# -- thin space
         | 16#200A# -- hair space
         | 16#202F# -- narrow no-break space
         | 16#205F# -- medium mathematical space
         | 16#3000# -- ideographic space
         =>
        -- ignore all blanks
        null;
 
      when 16#23# => -- '#'
        -- check for a digit, if there is one right after the '#'
        -- then we assume the base is missing; otherwise view the
        -- '#' as an invalid comment introducer
        get_character(f, ct2);
        status := get_status(ct2.c);
        if status /= aada_compiler_character_package.eol
        and then status /= aada_compiler_character_package.eof then
          if is_digit(get_ucs4_code(ct2.c), 36) then
            -- okay, so this is a digit, assume the base is missing
            aada_compiler_error_package.error(f.compiler_error,
                aada_compiler_error_package.unexpected_character_error,
                ct.position,
                "found a lone # character, assuming this is a number"
              & " and the base is missing");
            unget_character(f, ct2);
            unget_character(f, ct);
            set_ucs4_character(ct.c, 16#36#);
            unget_character(f, ct);
            get_number(f, 16#33#);
            return;
          end if;
        end if;
        -- '# ...': we assume we found a comment, skip it
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.unexpected_character_error,
            ct.position,
            "Ada does not support comments introduced with a # character;"
          & " skipping assuming it is a comment");
        status := get_status(ct2.c);
        loop
          exit when status = aada_compiler_character_package.eol
            or else status = aada_compiler_character_package.eof;
          get_character(f, ct);
          status := get_status(ct.c);
        end loop;
        -- comments are completely ignored like blanks
        -- FALLTHROUGH
 
      when 16#26# => -- '&'
        set_token(f, token_and, ct.c);
        return;
 
      when 16#27# => -- '''
        set_token(f, token_apostrophe, ct.c);
        return;
 
      when 16#28# => -- '('
        set_token(f, token_open_parenthesis, ct.c);
 
        -- check for '(*'
        get_character(f, ct2);
        status := get_status(ct2.c);
        if status /= aada_compiler_character_package.eol
        and then status /= aada_compiler_character_package.eof then
          if get_ucs4_code(ct2.c) = 16#2A# then
            aada_compiler_error_package.error(f.compiler_error,
                aada_compiler_error_package.unexpected_character_error,
                ct.position,
                "Pascal comments are not allowed in Ada");
          end if;
        else
          unget_character(f, ct2);
        end if;
        return;
 
      when 16#29# => -- ')'
        set_token(f, token_close_parenthesis, ct.c);
        return;
 
      when 16#2A# => -- '*'
        get_character(f, ct2);
        status := get_status(ct2.c);
        if status = aada_compiler_character_package.eol
        or else status = aada_compiler_character_package.eof then
          -- '*': just before the end of a line or end of the file
          set_token(f, token_multiply, ct.c);
        elsif get_ucs4_code(ct.c) = 16#2A# then
          -- '**': exponential
          set_token(f, token_exponential, ct.c);
          add_to_token(f, ct2.c);
        else
          -- '*': this is not exponential
          unget_character(f, ct2);
          set_token(f, token_multiply, ct.c);
        end if;
        return;
 
      when 16#2B# => -- '+'
        set_token(f, token_plus, ct.c);
        return;
 
      when 16#2C# => -- ','
        set_token(f, token_comma, ct.c);
        return;
 
      when 16#2D# => -- '-'
        get_character(f, ct2);
        status := get_status(ct2.c);
        if status = aada_compiler_character_package.eol
        or else status = aada_compiler_character_package.eof then
          -- '-': just before the end of a line or end of the file
          set_token(f, token_minus, ct.c);
          return;
        end if;
        if get_ucs4_code(ct2.c) = 16#2D# then
          -- '--': we found a comment, skip it
          loop
            get_character(f, ct);
            status := get_status(ct.c);
            exit when status = aada_compiler_character_package.eol
              or else status = aada_compiler_character_package.eof;
          end loop;
          -- comments are completely ignored like blanks
          -- FALLTHROUGH
        else
          -- '-': this is not a comment, restore the last get_character()
          unget_character(f, ct2);
          set_token(f, token_minus, ct.c);
          return;
        end if;
 
      when 16#2E# => -- '.'
        get_character(f, ct2);
        status := get_status(ct2.c);
        if status = aada_compiler_character_package.eol
        or else status = aada_compiler_character_package.eof then
          -- '.': just before the end of a line or end of the file
          set_token(f, token_divide, ct.c);
        elsif get_ucs4_code(ct2.c) = 16#2E# then
          -- '..': the double dot
          set_token(f, token_double_dot, ct.c);
          add_to_token(f, ct2.c);
        elsif get_ucs4_code(ct2.c) in 16#30# .. 16#39# then -- '0' .. '9'
          -- this is a digit! a period followed by a digit is most certainly
          -- a floating point with a missing 0 before the period
          aada_compiler_error_package.error(f.compiler_error,
              aada_compiler_error_package.invalid_floating_point_error,
              ct.position,
              "floating point numerals must start with a digit,"
            & " not a decimal point");
          -- transform into a valid floating point
          unget_character(f, ct2); -- put the digit back on the stack
          get_number(f, code);
        else
          -- '.': this is not the double dot
          unget_character(f, ct2);
          set_token(f, token_period, ct.c);
        end if;
        return;
 
      when 16#2F# => -- '/'
        get_character(f, ct2);
        status := get_status(ct2.c);
        if status = aada_compiler_character_package.eol
        or else status = aada_compiler_character_package.eof then
          -- '/': just before the end of a line or end of the file
          set_token(f, token_divide, ct.c);
          return;
        elsif get_ucs4_code(ct2.c) = 16#3D# then
          -- '/=': the inequality operator
          set_token(f, token_inequality, ct.c);
          add_to_token(f, ct2.c);
          return;
        elsif get_ucs4_code(ct2.c) = 16#2F# then
          -- '//': a C/C++ comment?
          aada_compiler_error_package.error(f.compiler_error,
              aada_compiler_error_package.invalid_floating_point_error,
              ct.position,
              "C/C++ comments are not allowed in ada,"
            & " skipping up to the end of the line");
          loop
            get_character(f, ct);
            status := get_status(ct.c);
            exit when status = aada_compiler_character_package.eol
              or else status = aada_compiler_character_package.eof;
          end loop;
          -- comments are completely ignored like blanks
          -- FALLTHROUGH
        elsif get_ucs4_code(ct2.c) = 16#2A# then
          -- '/* ...': a C/C++ comment introducer?
          aada_compiler_error_package.error(f.compiler_error,
              aada_compiler_error_package.invalid_floating_point_error,
              ct.position,
              """/*"" looks like a C/C++ comments introducer,"
            & " these are not allowed in Ada; ignored");
          -- if it was a comment introducer, we're in "trouble"
          -- anyway... (but since Ada does not support those,
          -- skipping to the next */ is not sensible)
          -- FALLTHROUGH
        else
          -- '/': this is not the inequality operator
          unget_character(f, ct2);
          set_token(f, token_divide, ct.c);
          return;
        end if;
 
      when 16#30# .. 16#39# => -- '0' .. '9'
        get_number(f, code);
        return;
 
      when 16#3A# => -- ':'
        get_character(f, ct2);
        status := get_status(ct2.c);
        if status = aada_compiler_character_package.eol
        or else status = aada_compiler_character_package.eof then
          -- ':': just before the end of a line or end of the file
          set_token(f, token_colon, ct.c);
        elsif get_ucs4_code(ct2.c) = 16#3D# then
          -- ':=': the inequality operator
          set_token(f, token_assignment, ct.c);
          add_to_token(f, ct2.c);
        else
          -- ':': this is not the assignment operator
          unget_character(f, ct2);
          set_token(f, token_colon, ct.c);
        end if;
        return;
 
      when 16#3B# => -- ';'
        set_token(f, token_semi_colon, ct.c);
        return;
 
      when 16#3C# => -- '<'
        get_character(f, ct2);
        status := get_status(ct2.c);
        if status = aada_compiler_character_package.eol
        or else status = aada_compiler_character_package.eof then
          -- '<': just before the end of a line or end of the file
          set_token(f, token_less, ct.c);
        else
          case get_ucs4_code(ct2.c) is
          when 16#3C# =>
            -- '<<': the left label mark
            set_token(f, token_left_label, ct.c);
            add_to_token(f, ct2.c);
          when 16#3D# =>
            -- '<=': the inequality operator
            set_token(f, token_less_equal, ct.c);
            add_to_token(f, ct2.c);
          when 16#3E# =>
            -- '<>': the box
            set_token(f, token_box, ct.c);
            add_to_token(f, ct2.c);
          when others =>
            -- '<': this is just less than
            unget_character(f, ct2);
            set_token(f, token_less, ct.c);
          end case;
        end if;
        return;
 
      when 16#3D# => -- '='
        get_character(f, ct2);
        status := get_status(ct2.c);
        if status = aada_compiler_character_package.eol
        or else status = aada_compiler_character_package.eof then
          -- '=': just before the end of a line or end of the file
          set_token(f, token_equal, ct.c);
        elsif get_ucs4_code(ct2.c) = 16#3E# then
          -- '=>': the arrow
          set_token(f, token_arrow, ct.c);
          add_to_token(f, ct2.c);
        else
          -- '=': this is not the assignment operator
          unget_character(f, ct2);
          set_token(f, token_equal, ct.c);
        end if;
        return;
 
      when 16#3E# => -- '>'
        get_character(f, ct2);
        status := get_status(ct2.c);
        if status = aada_compiler_character_package.eol
        or else status = aada_compiler_character_package.eof then
          -- '>': just before the end of a line or end of the file
          set_token(f, token_greater, ct.c);
        else
          case get_ucs4_code(ct2.c) is
          when 16#3E# =>
            -- '>>': the right label mark
            set_token(f, token_right_label, ct.c);
            add_to_token(f, ct2.c);
          when 16#3D# =>
            -- '>=': the greater than or equal
            set_token(f, token_greater_equal, ct.c);
            add_to_token(f, ct2.c);
          when others =>
            -- '>': this is just greater than
            unget_character(f, ct2);
            set_token(f, token_greater, ct.c);
          end case;
        end if;
        return;
 
      when 16#5F# =>
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.unexpected_underscore_error,
            ct.position,
            "underscores cannot appear as the first character of a numeral,"
          & "an identifier, or by itself");
        -- FALLTHROUGH -- we just skip this character!
 
      when 16#7B# => -- '{'
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.unexpected_character_error,
            ct.position,
            "to open a block use ""begin"" instead of {");
        return;
 
      when 16#7C# => -- '|'
        set_token(f, token_or, ct.c);
        return;
 
      when 16#D800# .. 16#DFFF# -- surrogates
        | 16#E000# .. 16#F8FF# -- private use
        | 16#F0000# .. 16#FFFFD#
        | 16#100000# .. 16#10FFFD# =>
        -- Other surrogate characters are forbidden
        aada_compiler_error_package.error(f.compiler_error,
            aada_compiler_error_package.unexpected_character_error,
            ct.position,
            "an unexpected character was"
          & " encountered outside of a comment");
 
      when others =>
        get_category(ct.c, category);
        case category is
        when unknown | invalid =>
          -- TODO: determine whether 'unknown' is a program error or input error
          -- 'invalid' should all be caught outside of this
          -- case so if we detect it here we have a problem
          raise program_error;
 
        when other | punctuation | format =>
          -- TODO: generate an error
          aada_compiler_error_package.error(f.compiler_error,
              aada_compiler_error_package.unexpected_character_error,
              ct.position,
              "an unexpected (formatting, punctuation) character was"
            & " encountered outside of an identifier or literal");
          -- in this case we continue
 
        when letter =>
          -- found an identifier
          set_token(f, token_identifier, ct.c);
          ascii_token := is_ascii(ct.c);
          last_character_category := letter;
          loop
            get_character(f, ct);
            status := get_status(ct.c);
            exit when status = aada_compiler_character_package.eol
              or else status = aada_compiler_character_package.eof;
            get_category(ct.c, category);
            if category not in letter .. format then
              -- restore this character for next round
              unget_character(f, ct);
              exit;
            end if;
            if ascii_token and then not is_ascii(ct.c) then
              ascii_token := false;
            end if;
            -- for this test, ignore formatting characters
            if category /= format then
              if last_character_category = punctuation
              and then category = punctuation then
                aada_compiler_error_package.error(f.compiler_error,
                    aada_compiler_error_package.two_punctuation_error,
                    ct.position,
                    "found two punctuation characters"
                  & " in a row in an identifier");
              end if;
              last_character_category := category;
            end if;
            add_to_token(f, ct.c);
          end loop;
          if last_character_category = punctuation then
            aada_compiler_error_package.error(f.compiler_error,
                aada_compiler_error_package.illegal_punctuation_error,
                ct.position,
                "found an illegal punctuation character"
              & " at the end of an identifier");
          end if;
          -- check whether this identifier is a reserved word
          identifier_to_reserved_word(f, ascii_token);
          return;
 
        end case;
      end case;
 
    when others =>
      -- should not happen as the character package should raise an error
      raise program_error;
 
    end case;
  end loop;
end get_token_literal;
 
procedure get_token(f: in out compiler_token_input_type) is
begin
  get_token_literal(f);
  if f.literal_size > 0 then
    -- copy the literal in the token if any
    -- (this is dynamically copied to reduce the size as much as possible)
    get_utf8_string(f.literal(integer(f.literal'first)
                           .. integer(f.literal_size)),
                f.token.literal);
  else
    -- reset to empty on eof (necessary?!)
    aada_vstrings.vstr("", f.token.literal);
  end if;
end get_token;
 
procedure next_token(f: in out compiler_token_input_type;
                     t: out compiler_token_type) is
begin
  -- is there a look-ahead token? if so, return it instead
  if f.look_ahead.token /= token_nil then
    t := f.look_ahead;
    f.look_ahead.token := token_nil;
    return;
  end if;
  loop
    get_token(f);
    t := f.token;
    -- although at this time we should never return a NIL token
    -- we do the test here, just in case we change our mind
    exit when t.token /= token_nil;
  end loop;
end next_token;
 
procedure unget_token(f: in out compiler_token_input_type;
                      t: in compiler_token_type) is
begin
  -- TBD: we may want to have a stack instead of just one item
  if f.look_ahead.token /= token_nil then
    raise token_look_ahead_buffer_full;
  end if;
  f.look_ahead := t;
end unget_token;
 
function get_token_token(t: in compiler_token_type) return ada_token is
begin
  return t.token;
end get_token_token;
 
procedure set_token_token(t: in out compiler_token_type; token: ada_token) is
begin
  -- to make the change secure we avoid changing tokens at will
  case token is
  when token_null_record =>
    if t.token = token_record then
      t.token := token;
      return;
    end if;
 
  when others => null;
  end case;
 
  -- any other case we refuse to change the token
  raise token_change_not_allowed;
end set_token_token;
 
function get_token_position(t: in compiler_token_type)
                    return aada_compiler_token_position.token_position_type is
begin
  return t.position;
end get_token_position;
 
procedure get_token_operator(--f: in out compiler_token_input_type;
                             t: in out compiler_token_type;
                             token: out ada_token) is
begin
  --
  -- a string token can represent an operator; this is true
  -- in a function declaration:
  --    function "**" (a, b: this_type) return that_type;
  -- and also in an expression as in:
  --    a := "**" (b, c);
  -- plus it is possible to qualify the operator in an expression
  --    a := b."**" (c, d);
  --
  if t.operator = token_unknown then
    -- check whether this token can represent an operator
    if t.token /= token_string then
      -- only strings can be used to this effect
      -- we should never be called otherwise!!!
      raise program_error;
    elsif t.uppercase = "&" then
      t.operator := token_and;
    elsif t.uppercase = "*" then
      t.operator := token_multiply;
    elsif t.uppercase = "**" then
      t.operator := token_exponential;
    elsif t.uppercase = "+" then
      t.operator := token_plus;
    elsif t.uppercase = "-" then
      t.operator := token_minus;
    elsif t.uppercase = "/" then
      t.operator := token_divide;
    elsif t.uppercase = "/=" then
      t.operator := token_inequality;
    elsif t.uppercase = "<" then
      t.operator := token_less;
    elsif t.uppercase = "<=" then
      t.operator := token_less_equal;
    elsif t.uppercase = "=" then
      t.operator := token_equal;
    elsif t.uppercase = ">" then
      t.operator := token_greater;
    elsif t.uppercase = ">=" then
      t.operator := token_greater_equal;
    elsif t.uppercase = "ABS" then
      t.operator := token_abs;
    elsif t.uppercase = "AND" then
      t.operator := token_and;
    elsif t.uppercase = "MOD" then
      t.operator := token_mod;
    elsif t.uppercase = "NOT" then
      t.operator := token_not;
    elsif t.uppercase = "OR" then
      t.operator := token_or;
    elsif t.uppercase = "REM" then
      t.operator := token_rem;
    elsif t.uppercase = "XOR" then
      t.operator := token_xor;
    else
      -- none of the 19 allowed operators
      -- TODO: try a "trim()" of the keyword and check again
      --       so we can err intelligently in the event the
      --       user added spaces
      t.operator := token_nil;
      --aada_compiler_error_package.error(f.compiler_error,
      --    aada_compiler_error_package.unknown_operator_error,
      --    t.position,
      --    "an operator was expected; """ & aada_vstrings.str(t.literal)
      --                                      & """ was found instead");
    end if;
  end if;
  token := t.operator;
end get_token_operator;
 
function get_token_literal(t: in compiler_token_type)
                      return aada_vstrings.vstring is
begin
  return t.literal;
end get_token_literal;
 
function get_token_uppercase(t: in compiler_token_type)
                      return aada_vstrings.vstring is
begin
  return t.uppercase;
end get_token_uppercase;
 
 
end aada_compiler_token_package;
 
-- vim: ts=2 sw=2 et syntax=ada