Alexis Ada Reference Manual

with interfaces;
with ada.strings;
with ada.strings.fixed;
with ada.streams.stream_io;
with ada.characters.latin_1;
with aada_character_categories;
with aada_compiler_ucs4_string_normalized_uppercase;
 
-- we need many operators so use is required
use interfaces;
use ada.streams;
 
package body aada_compiler_character_package is
 
 
 
procedure init_character(c: out compiler_character; status: character_status) is
begin
  c.status := status;
  c.category := unknown;
  c.ucs4 := 16#FEFF#; -- endian mark
  c.utf8_length := 0;
  c.utf8 := (others => 16#20#);
end init_character;
 
-- 's' must be long enough to accept the transliteration, if not
-- an overflow error will be raised; to support all languages,
-- it should be 5 x the size of 'u'
--
-- note that proper transformation from lower to uppercase
-- requires the entire entity (identifier) instead of just one
-- character at a time
--
-- Unicode algorithms used to compute the uppercase letters are:
--    1. Normalization expension,
--    2. Uppercasing,
--    3. Normalized compression.
--
-- When the input string is only composed of ISO-8859-1 characters
-- then we do the uppercasing right here. If any other character
-- appears in the string, then the full Unicode transformation is used.
-- Note that since 99.9% of the identifiers are using ASCII (especially
-- all keywords are ASCII only,) this will take care of most of the
-- strings.
--
-- Unicode string normalization (Chapter 5.6 as of 6.0.0)
--      http://www.unicode.org/reports/tr15/
--
-- Uppercasing is defined in Chapter 5.8 as:
--      http://www.unicode.org/versions/Unicode6.0.0/ch05.pdf#G21180
--      Q(X) = NFC(toUppercase(NFD(X)))
--
-- So we use the normalization to expand X, compute uppercase,
-- then apply NFC which shrink X as much as possible.
--
-- See also node #44 in regard to case mapping, the Simple case mapping
-- can be used when no special case mapping exists for the transformation
--      http://www.unicode.org/reports/tr44/#Casemapping
--
procedure get_uppercase_string(u: in compiler_character_string;
                               s: out compiler_character_string) is
  -- modular definitions used for the and operation
  type ucs4_modular is mod 16#7FFFFFFF#;
 
  -- ISO-10646:2003 does not define all the pages, but we want to support
  -- them all in the compiler; we accept unknown character as is
  -- the page are the higher 23 bits (bit 31 unused)
  type character_page is range 0 .. 16#7FFFFF#;
 
  page: character_page;
  i: positive := u'first;
  j: positive := s'first;
begin
  -- reset the output string with nil characters
  -- this would just be a waste of time; we just terminate the string that way
  -- (see end of function)
 
  whole_string:
  while i <= u'last
  loop
 
    -- determine the page number
    page := character_page(shift_right(unsigned_32(u(i).ucs4), 8));
 
    -- special case since 99% of the program content will be in 7bits ASCII
    if page /= 0 then
      -- the string includes characters that are outside the
      -- ISO-8859-1 page, so we have to call the UCS-4 uppercase
      -- function to make sure the transliteration is complete
      -- as expected
 
      declare
        temp: ucs4_string(1 .. u'length);
        vtemp: ucs4_vstring;
      begin
        for k in positive range u'range
        loop
          temp(ucs4_string_length(k - u'first + 1)) := u(k).ucs4;
        end loop;
        vstr(temp, vtemp);
        -- normalized uppercase transliterations
        aada_compiler_ucs4_string_normalized_uppercase
                                  .ucs4_string_to_normalized_uppercase(vtemp);
        j := s'first;
        for k in ucs4_string_length range 1 .. length(vtemp)
        loop
          init_character(s(j), valid);
          s(j).ucs4 := get(vtemp, k);
          j := j + 1;
        end loop;
      end;
 
      exit whole_string;
    end if;
 
    -- ISO 8859-1 (Latin 1) uppercase transliterations done manually
    -- (this is a lot faster than calling the full UCS-4 uppercase
    -- implementation and useful 99.9% of the time)
    case u(i).ucs4 is
    when 16#61# .. 16#7A# -- 'a' .. 'z'
       | 16#E0# .. 16#F6# -- accentuated A, E, I, and O; AE ligature;
                          -- C cedilla; EDH; N tilde
       | 16#F8# .. 16#FE# -- accentuated U, Y; ETH
            => init_character(s(j), valid);
               s(j).ucs4 := ucs4_character(
                                ucs4_modular(u(i).ucs4) and 16#DF#);
               j := j + 1;
 
    when 16#B5# -- Micro Sign
            => init_character(s(j), valid);
               s(j).ucs4 := 16#3BC#;
               j := j + 1;
 
    when 16#DF# -- German Sharp S
            => init_character(s(j), valid);
               init_character(s(j + 1), valid);
               s(j).ucs4 := 16#53#;
               s(j + 1).ucs4 := 16#53#;
               j := j + 2;
 
    when 16#FF# -- Y with dialesis
            => init_character(s(j), valid);
               s(j).ucs4 := 16#178#;
               j := j + 1;
 
    when 16#AD# -- format (small dash), ignore
            => null;
 
    when others -- other characters do not require any transformation
            => s(j) := u(i);
               j := j + 1;
 
    end case;
 
    i := i + 1;
  end loop whole_string;
  -- end the string with a NIL character
  if j <= s'last then
    init_character(s(j), nil);
  end if;
end get_uppercase_string;
 
 
procedure utf8_buffer_put_byte(u: in out utf8_buffer; b: in utf8_byte) is
begin
  if u.index = utf8_index'last then
    raise utf8_buffer_full_error;
  end if;
  u.index := utf8_index'succ(u.index);
  u.buffer(u.index) := b;
end utf8_buffer_put_byte;
 
function utf8_buffer_is_empty(u: in utf8_buffer) return boolean is
begin
  return u.index = utf8_index'first;
end utf8_buffer_is_empty;
 
function utf8_buffer_is_full(u: in utf8_buffer) return boolean is
begin
  return u.index = utf8_index'last;
end utf8_buffer_is_full;
 
procedure set_utf8_string(c: out compiler_character; u: in out utf8_buffer) is
  -- declare the necessary constant to check the largest character
  -- based on the length of the UTF-8 character for proper normalization
  -- note that the last value of ucs4_character is expected to be 16#7FFFFFFD#
  type char_size is array(1 .. 6) of ucs4_character;
  max_for_size: constant char_size := (16#7F#, 16#7FF#, 16#FFFF#,
                                       16#1FFFFF#, 16#3FFFFFF#, 16#7FFFFFFD#);
 
  -- local variable
  b: utf8_byte; -- first byte of the UTF-8 sequence
  r: unsigned_32; -- should be ucs4_character, but it may be 0 at some point
  n: utf8_string_length; -- number of bytes in UTF-8 sequence
  s: character_status; -- valid or unnormalized
  ib: constant := utf8_string_buffer'first; -- the first index in u
 
begin
  if utf8_buffer_is_empty(u) then
    -- an empty UTF-8 string is equivalent to a null character
    init_character(c, nil);
    return;
  end if;
 
  b := u.buffer(ib);
  if b < 16#80# then
    -- a "stand-alone" character (more or less, a 7 bits ASCII character)
    init_character(c, valid);
    r := unsigned_32(b);
    n := 1;
  elsif b < 16#C0# then
    -- invalid size? (codes 16#80# to 16#BF# are not valid UTF-8 introducers)
    init_character(c, error);
    raise byte_sequence_error;
  elsif b < 16#E0# then -- two bytes character?
    r := unsigned_32(b) and 16#1F#;
    n := 2;
  elsif b < 16#F0# then -- three bytes character?
    r := unsigned_32(b) and 16#0F#;
    n := 3;
  elsif b < 16#F8# then -- four bytes character?
    r := unsigned_32(b) and 16#07#;
    n := 4;
  elsif b < 16#FC# then -- five bytes character?
    r := unsigned_32(b) and 16#03#;
    n := 5;
  elsif b <= 16#FD# then -- six bytes character? (1 bit + 5 x 6 bits = 31 bits)
    r := unsigned_32(b) and 16#01#;
    n := 6;
  else
    -- unless the definition of the UTF-8 byte is incorrect this cannot occur
    raise program_error;
  end if;
 
  -- we expect up to 6 bytes, but the input could be much smaller
  if n > u.index then
    init_character(c, error);
    raise sequence_too_short_error;
  end if;
 
  -- verify that all the following bytes are valid
  -- and as we're at it, generate the final UCS-4 value
  if n > 1 then
    -- (ib + 1) because we already read (ib)
    for i in utf8_index_buffer_range range ib + 1 .. ib + n - 1
    loop
      if u.buffer(i) not in 16#80# .. 16#BF# then
        init_character(c, error);
        raise byte_sequence_error;
      end if;
      r := shift_left(r, 6) or (unsigned_32(u.buffer(i)) and 16#3F#);
    end loop;
 
    -- verify that the least significant 16 bits are valid
    -- (note no need to check the 7 bits characters here)
    if r = 0 or else (r and 16#FFFF#) in 16#FFFE# .. 16#FFFF# then
      init_character(c, illegal);
      raise illegal_character_error;
    end if;
  end if;
 
  -- check whether the character is normalized
  -- when it is 1 byte it is always valid
  -- max size is: shift_right(16#7FFFFFFF#, (6 - n) * 5)
  -- except when n = 1 in which case it's 16#7F#
  s := valid;
  if n > 1 then
    if ucs4_character(r) <= max_for_size(integer(n - 1)) then
      s := unnormalized;
    end if;
  end if;
 
  -- set the character
  init_character(c, s);
  c.ucs4 := ucs4_character(r);
  c.utf8_length := n;
  c.utf8(1 .. n) := u.buffer(ib .. ib + n - 1); -- copy the slice we just eat
  -- (note that this copy is not always normalized)
 
  -- we just eat n bytes
  u.index := u.index - n;
 
  -- eat the slice we just used, it's saved in the character now
  if u.index > 0 then
    u.buffer(ib .. ib + u.index - 1) := u.buffer(ib + n .. ib + n + u.index - 1);
  end if;
 
  -- note: the category is left unknown, if queried and the character
  --       is valid, then we compute it;
  --       similarly, we do not define the upper case letter just yet
end set_utf8_string;
 
procedure set_ucs4_character(c: out compiler_character; u: in ucs4_character) is
begin
  -- this one is very easy, but we still check that it is valid
  if (unsigned_32(u) and 16#FFFF#) in 16#FFFE# .. 16#FFFF# then
    init_character(c, illegal);
    raise illegal_character_error;
  end if;
  -- the UTF-8 string will be computed only if necessary and so is the category
  init_character(c, valid);
  c.ucs4 := u;
end set_ucs4_character;
 
procedure get_special_character(c: out compiler_character;
                                status: in special_character_status) is
begin
  init_character(c, status);
end get_special_character;
 
pragma inline(get_status);
function get_status(c: in compiler_character) return character_status is
begin
  return c.status;
end get_status;
 
pragma inline(is_ascii);
function is_ascii(c: in compiler_character) return boolean is
begin
  if c.status not in valid .. unnormalized then
    raise illegal_character_error;
  end if;
  return c.ucs4 < 16#7F#;
end is_ascii;
 
procedure get_category(c: in out compiler_character;
                       category: out character_category) is
begin
  if c.status not in valid .. unnormalized then
    raise illegal_character_error;
  end if;
  -- if still unknown we want to determine the category now
  if c.category = unknown then
    -- get the actual character category
    c.category := aada_character_categories.character_to_category(c.ucs4);
  end if;
  category := c.category;
end get_category;
 
-- 'output' should be at least get_utf8_length() characters starting at 1
-- the output is a normalized UTF-8 string; this is used to generate the
-- vstring as defined in get_utf8_string() and get_uppercase()
procedure retrieve_utf8_string(s: in compiler_character_string;
                               output: out string) is
  p: integer := 1;
  u: utf8_string(utf8_index_buffer_range'range);
  l: utf8_string_length;
begin
  for i in s'first .. s'last
  loop
    exit when s(i).status = nil;
    get_normalized_utf8_code(s(i), u, l);
    for j in utf8_string_length range 1 .. l
    loop
      -- transform UTF-8 to regular Latin 1 characters for easy handling
      output(p) := character'val(u(j));
      p := p + 1;
    end loop;
  end loop;
end retrieve_utf8_string;
 
procedure get_utf8_string(s: in compiler_character_string;
                          u: in out aada_vstrings.vstring) is
  l: utf8_string_length;
begin
  l := get_utf8_length(s);
  declare
    output: string(1 .. integer(l));
  begin
    retrieve_utf8_string(s, output);
    aada_vstrings.vstr(output, u);
  end;
end get_utf8_string;
 
function get_utf8_length(s: in compiler_character_string)
                                                   return utf8_string_length is
  length: utf8_string_length := 0;
begin
  for i in s'first .. s'last
  loop
    -- upper case buffer ends with a NIL character
    exit when s(i).status = nil;
    length := length + get_normalized_utf8_code_length(s(i));
  end loop;
  return length;
end get_utf8_length;
 
procedure get_uppercase(s: in compiler_character_string;
                        u: in out aada_vstrings.vstring) is
  -- any one character can be quintupled when transformed to upper case
  -- i.e. German Sharp S (1 byte) becomes SS (2 bytes)
  -- but some characters may use more space if they are followed by
  -- modifiers (i.e. accents and other diacritics)
  upper: compiler_character_string(1 .. s'length * 5 + 1);
  l: utf8_string_length;
begin
  -- the get_uppercase_string() ends the upper string with a NIL character
  get_uppercase_string(s, upper);
  l := get_utf8_length(upper);
  declare
    output: string(1 .. integer(l));
  begin
    retrieve_utf8_string(upper, output);
    aada_vstrings.vstr(output, u);
  end;
end get_uppercase;
 
pragma inline(eof);
function eof(c: in compiler_character) return boolean is
begin
  return c.status = eof;
end eof;
 
pragma inline(is_valid);
function is_valid(c: in compiler_character) return boolean is
begin
  return c.status not in invalid .. error;
end is_valid;
 
pragma inline(get_ucs4_code);
function get_ucs4_code(c: in compiler_character) return ucs4_character is
begin
  if c.status not in valid .. unnormalized then
    raise illegal_character_error;
  end if;
  return c.ucs4;
end get_ucs4_code;
 
procedure get_utf8_code(c: in out compiler_character;
                        u: out utf8_string;
                        l: out utf8_string_length) is
  ib: utf8_string_length; -- first character index in u
begin
  if c.status not in valid .. unnormalized then
    raise illegal_character_error;
  end if;
  ib := u'first;
  if c.utf8_length = 0 then
    -- get the normalized code and bufferize it
    get_normalized_utf8_code(c, u, l);
    c.utf8_length := l;
    for i in utf8_index_buffer_range range utf8_string_buffer'first .. l
    loop
      c.utf8(i) := u(ib + i - 1);
    end loop;
  else
    l := c.utf8_length;
    u(ib .. ib + l - 1) := utf8_string(c.utf8(1 .. l));
  end if;
end get_utf8_code;
 
function get_normalized_utf8_code_length(c: in compiler_character)
                                     return utf8_string_length is
begin
  if c.status not in valid .. unnormalized then
    raise illegal_character_error;
  end if;
  if c.ucs4 <= 16#7F# then
    -- special case of the 7 bit characters
    return 1;
  elsif c.ucs4 <= 16#7FF# then
    return 2;
  elsif c.ucs4 <= 16#FFFF# then
    return 3;
  elsif c.ucs4 <= 16#1FFFFF# then
    return 4;
  elsif c.ucs4 <= 16#3FFFFFF# then
    return 5;
  else -- if c.ucs4 <= 16#7FFFFFFF# then
    return 6;
  end if;
end get_normalized_utf8_code_length;
 
procedure get_normalized_utf8_code(c: in compiler_character;
                                   u: out utf8_string;
                                   l: out utf8_string_length) is
  r: unsigned_32;
begin
  l := 0;
  u := (others => 16#20#);
  if c.status not in valid .. unnormalized then
    raise illegal_character_error;
  end if;
  if c.ucs4 <= 16#7F# then
    -- special case of the 7 bit characters
    l := 1;
    u(1) := utf8_byte(c.ucs4);
    return;
  elsif c.ucs4 <= 16#7FF# then
    l := 2;
  elsif c.ucs4 <= 16#FFFF# then
    l := 3;
  elsif c.ucs4 <= 16#1FFFFF# then
    l := 4;
  elsif c.ucs4 <= 16#3FFFFFF# then
    l := 5;
  else -- if c.ucs4 <= 16#7FFFFFFF# then
    l := 6;
  end if;
 
  -- convert UCS-4 to UTF-8
  r := unsigned_32(c.ucs4);
  for i in reverse utf8_string_length range 2 .. l
  loop
    u(i) := utf8_byte((r and 16#3F#) or 16#80#);
    r := shift_right(r, 6);
  end loop;
  u(1) := utf8_byte((r or shift_right(16#FF00#, integer(l))) and 16#FF#);
end get_normalized_utf8_code;
 
end aada_compiler_character_package;
-- vim: ts=2 sw=2 et syntax=ada