gcc/testsuite/gnat.dg/gen_disp.adb

   1 --  { dg-do compile }
   2 with Ada.Containers.Ordered_Maps;
   3 with Ada.Tags.Generic_Dispatching_Constructor;
   4 package body gen_disp is
   5
   6    use type Ada.Tags.Tag;
   7
   8    function "<" (L, R : in Ada.Tags.Tag) return Boolean is
   9    begin
  10       return Ada.Tags.External_Tag (L) < Ada.Tags.External_Tag (R);
  11    end "<";
  12
  13    package Char_To_Tag_Map is new Ada.Containers.Ordered_Maps (
  14       Key_Type => Character,
  15       Element_Type => Ada.Tags.Tag,
  16       "<" => "<",
  17       "=" => Ada.Tags. "=");
  18
  19    package Tag_To_Char_Map is new Ada.Containers.Ordered_Maps (
  20       Key_Type => Ada.Tags.Tag,
  21       Element_Type => Character,
  22       "<" => "<",
  23       "=" => "=");
  24
  25    use type Char_To_Tag_Map.Cursor;
  26    use type Tag_To_Char_Map.Cursor;
  27
  28    Char_To_Tag : Char_To_Tag_Map.Map;
  29    Tag_To_Char : Tag_To_Char_Map.Map;
  30
  31    function Get_Object is new
  32      Ada.Tags.Generic_Dispatching_Constructor
  33         (Root_Type, Ada.Streams.Root_Stream_Type'Class, Root_Type'Input);
  34
  35    function Root_Type_Class_Input
  36      (S    : not null access Ada.Streams.Root_Stream_Type'Class)
  37       return Root_Type'Class
  38    is
  39       External_Tag : constant Character := Character'Input (S);
  40       C : constant Char_To_Tag_Map.Cursor := Char_To_Tag.Find (External_Tag);
  41    begin
  42
  43       return Get_Object (Char_To_Tag_Map.Element (C), S);
  44    end Root_Type_Class_Input;
  45 end gen_disp;