------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . M A P P I N G                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2011, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU  General  Public  License  distributed with ASIS-for-GNAT;  see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  AdaCore                   --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines and implements the mapping from the nodes in the
--  tree created by the front-end nodes onto ASIS Elements.
--  The main part of this mapping are:
--
--  - the function constructing an ASIS Element from a tree
--    node;
--  - the function constructing an ASIS Element_List from a tree node
--    list;
--  - a set of functions defining the ASIS kind (or, more exactly, the
--    corresponding value of the Internal_Element_Kinds type) of an Element
--    which can be built on the base of a given node. Most of these functions
--    are hidden in the package body, but for some of them their
--    specifications are placed in the package spec in order to make them
--    visible for the implementation of some ASIS queries (for example,
--    sometimes we have to know the exact kind of an operator symbol or
--    of an attribute reference.

--  The functions defined in this package are of relatively low level. In
--  particular, as a rule, they do not check the correctness of their
--  arguments, and a caller is responsible for the correct usage of these
--  functions.

with Asis;

with A4G.A_Types;  use A4G.A_Types;
with A4G.Int_Knds; use A4G.Int_Knds;

with Types;        use Types;
with Sinfo;        use Sinfo;

package A4G.Mapping is

   Parent_Node : Node_Id;
   --  The determination of the ASIS Internal Element Kind is based on
   --  the original tree nodes. Sometimes it requires information about
   --  the "context" of a node, that is, about its the parent node.
   --  If the node is rewritten, its original node has Parent field
   --  set to N_Empty. The global variable Parent_Node is used to
   --  transfer the parent node from Node_To_Element function to
   --  Asis_Internal_Element_Kind function.
   --
   --  ???
   --  For now, it is defined in the package spec, because it is needed
   --  by the current implementation of Enclosing_Element. As soon as
   --  the implementation of Enclosing _Element is rewritten on top of
   --  Traverse_Element, the declaration of Parent_Node should be
   --  moved in the body of the package.

   function Asis_Internal_Element_Kind
     (Node : Node_Id)
      return Internal_Element_Kinds;
   --  This function is the kernel of the tree node -> Asis Element
   --  mapping. Taking a tree Node, it defines the Internal_Element_Kinds
   --  value for the Element which may be constructed on the base of this
   --  node. Node should be an original, but not the rewritten node in case
   --  if tree rewriting takes place for a given construct.
   --
   --  This function does not check, whether or not an Element could be
   --  really construct for a given Node, a caller is responsible for
   --  obtaining the proper node for Element construction, or for filtering
   --  out inappropriate nodes in case when this function is applied
   --  to construct an Element_List.
   --
   --  If no Asis_Element could be constructed on the base of the Node, then
   --  ASIS_Failed is raised.
   --
   --  This function is placed in the package spec, because it is needed
   --  by A4G.CU_Info2 routines

   function N_Operator_Symbol_Mapping
     (Node : Node_Id)
      return Internal_Element_Kinds;
   --  One of the functional components of the general
   --  Asis_Internal_Element_Kind function, it is placed in the package spec
   --  because it is needed by Asis.Expressions.Prefix.
   --  function.

   function Is_Not_Duplicated_Decl (Node : Node_Id) return Boolean;
   --  This function checks if Node does not correspond to the declaration
   --  which is included in the tree twice - first on its own and then
   --  as an original node for some rewritten structure. For instance, this
   --  is the case for a type derived from private type and having no
   --  explicit constrain.
   --
   --  This function return False for the second of the two duplicated
   --  declarations.
   --
   --  This function is placed in the package spec, because it is used by
   --  A4G.Decl_Sem.Serach_First_View

   function Subprogram_Attribute_Kind
     (Node : Node_Id)
      return Internal_Element_Kinds;
   --  This function defines the kind of an Element which can be built on
   --  N_Attribute_Reference node corresponding to a reference to
   --  attribute-subprogram, but opposite to the general attribute kind
   --  determination implemented by N_Attribute_Reference_Mapping, it does
   --  not classify an Element as a function or a procedure call, but it
   --  defines the corresponding Attribute_Kinds value.

   function Is_GNAT_Attribute_Routine (N : Node_Id) return Boolean;
   --  Checks if N represents a GNAT-specific attribute which is a function or
   --  a procedure

   function Is_Rewritten_Function_Prefix_Notation
     (N     : Node_Id)
      return Boolean;
   --  Checks if N represents a function call given in Object.Operation [(...)]
   --  form. In this case N is a rewritten node, and the original subtree
   --  is not decorated and the original node is not even classified as
   --  a function call

   function Is_Rewritten_Impl_Deref_Function_Prefix_Notation
     (N     : Node_Id)
      return Boolean;
   --  Checks if N represents a function call given in Object.Operation [(...)]
   --  for a special case when the call is used in implicit dereference (the
   --  caller is responsible to call this function only for nodes corresponding
   --  to implicit dereference!)

   function Node_To_Element_New
     (Node                     : Node_Id;
      Node_Field_1             : Node_Id                := Empty;
      Node_Field_2             : Node_Id                := Empty;
      Starting_Element         : Asis.Element           := Asis.Nil_Element;
      Internal_Kind            : Internal_Element_Kinds := Not_An_Element;
      Spec_Case                : Special_Cases          := Not_A_Special_Case;
      Norm_Case                : Normalization_Cases    := Is_Not_Normalized;
      Considering_Parent_Count : Boolean                := True;
      Using_Original_Node      : Boolean                := True;
      Inherited                : Boolean                := False;
      In_Unit          : Asis.Compilation_Unit  := Asis.Nil_Compilation_Unit)
      return Asis.Element;
   --  This functions creates the ASIS Element which could be built on the
   --  basis of Node. Its other parameters have the following meaning (the
   --  wording "the parameter is set" means below that some non-nil value
   --  is explicitly passed in the call):
   --
   --  Starting_Element - if this parameter is set, the following fields
   --     of the result Element are set as being equal to the corresponding
   --     fields of Starting_Element:
   --
   --     -  Enclosing_Unit (unless the In_Unit parameter is set);
   --     -  Enclosing_Context (unless the In_Unit parameter is set);
   --     -  Is_Part_Of_Implicit;
   --     -  Is_Part_Of_Inherited;
   --     -  Is_Part_Of_Instance;
   --     -  Special_Case (unless the Special_Case parameter is set);
   --     -  Node_Field_1 (unless the Node_Field_1 parameter is set)
   --     -  Node_Field_2 (unless the Node_Field_2 parameter is set)
   --  The typical situation of using this function in the implementations of
   --  ASIS (structural) queries is to set Starting_Element as being equal to
   --  the argument Element of the ASIS query.
   --
   --     If Starting_Element is not set, the corresponding fields of the
   --     result are computed from Node.
   --
   --  Internal_Kind - if this parameter is set, its value is set as the
   --     value of the Internal_Kind field of the result Element. Otherwise
   --     the kind of the result Element is determined automatically
   --
   --  Spec_Case  - if this parameter is set, its value is set as the
   --     value of the Special_Case field of the result Element. Otherwise
   --     the value of the Special_Case field of the result Element is set
   --     from Starting_Element, if Starting_Element itself is set, or as
   --     being equal to Not_A_Special_Case, if Starting_Element is not set.
   --
   --  Norm_Case - This parameter represents if the Element to create is a
   --     normalized association. It is not processed by this routine and it
   --     is transferred as-is to the low-level Element construction routine.
   --
   --  Considering_Parent_Count - boolean flag indicating if the value of the
   --     Parent_Count field of the Node should be taken into account for the
   --     definition of the kind of the Asis Element to be returned by the
   --     function.
   --
   --  Using_Original_Node - boolean flag indicating if the original node
   --     should be used as the basis of the Element being constructed.
   --     Usually the default True is used, but sometimes we have to
   --     avoid using the original node, for example, when constructing the
   --     expanded spec for a generic instantiation in case of a library_item
   --
   --  Inherited - boolean flag indicating if the element being constructed
   --     represents a declaration of an implicit inherited subprogram or a
   --     subcomponent thereof.
   --     ??? why do we need it???
   --
   --  In_Unit - The Asis Compilation Unit, to which the Element being
   --     constructed belongs. It is an error not to set both Starting_Element
   --     and In_Unit parameters. If both of them are set, the value of
   --     the Enclosing_Unit and Enclosing_Context fields of the result
   --     Element are set from In_Unit
   --
   --  NOTE, that if Starting_Element is NOT set, the Is_Part_Of_Implicit and
   --  the Is_Part_Of_Inherited fields  of  the result are set off (equal to
   --  False), therefore the caller (that is, the implementation of the
   --  corresponding ASIS query) is responsible for correct setting of these
   --  fields. As for the Is_Part_Of_Instance field, it is set on the base of
   --  Sloc field of the corresponding Node. (???)
   --
   --  An Empty node is not an expected parameter for this function. But if it
   --  is passed as an actual for Node, the result of the function is
   --  Nil_Element, independently of all the other parameters.

   function N_To_E_List_New
     (List             : List_Id;
      Include_Pragmas  : Boolean                := False;
      Starting_Element : Asis.Element           := Asis.Nil_Element;
      Node_Knd         : Node_Kind              := N_Empty;
      Internal_Kind    : Internal_Element_Kinds := Not_An_Element;
      Special_Case     : Special_Cases          := Not_A_Special_Case;
      Norm_Case        : Normalization_Cases    := Is_Not_Normalized;
      In_Unit          : Asis.Compilation_Unit  := Asis.Nil_Compilation_Unit)
      return Asis.Element_List;
   --  This function converts tree Node list into the corresponding ASIS
   --  Element List.
   --
   --  This function is intended to be used to create lists of EXPLICIT
   --  ASIS Elements. It checks Comes_From_Source Flag of the tree nodes from
   --  its List argument to test if the node should be used to create an
   --  Element in the result Element list
   --
   --  The parameters have the following meaning (we say "if the parameter
   --  is set" with the meaning "if some actual different from the default
   --  nil value is passed for the parameter")
   --
   --    List - specifies the tree node list to be converted into an ASIS
   --           Element List;
   --
   --    Include_Pragmas - boolean flags signifying if pragmas should be
   --           included in the result list;
   --
   --    Node_Knd - if this parameter is set, only those nodes from List
   --           which have this node kind are used to construct Elements in
   --           the result Element List;
   --
   --    Internal_Kind - if this parameter is set, all the Elements of the
   --           result list are set having this kind, otherwise the kind
   --           of each element of the result list is determined
   --           automatically;
   --
   --    Special_Case  - if this parameter is set, all the Elements of the
   --           result list are set having this special case;
   --
   --    Norm_Case  - if this parameter is set, all the Elements of the
   --           result list are set having this normalization case;
   --
   --    Starting_Element - the following fields of all the Elements in
   --           the result Element List are set as being equal to the
   --           corresponding fields of Starting_Element:
   --             -  Enclosing_Unit (unless the In_Unit parameter is set);
   --             -  Enclosing_Context (unless the In_Unit parameter is set);
   --             -  Is_Part_Of_Implicit;
   --             -  Is_Part_Of_Inherited;
   --             -  Is_Part_Of_Instance;
   --             -  Special_Case (unless the Special_Case parameter is set);
   --           Setting Starting_Element as being equal to the argument
   --           Element of the ASIS query where N_To_E_List is called
   --           to form the result of the query is the common case for the
   --           ASIS structural queries
   --
   --    In_Unit - The Asis Compilation Unit, to which the Elements being
   --           constructed belong. It is an error not to set both
   --           Starting_Element and In_Unit parameters. If both of them
   --           are set, the value of the Enclosing_Unit and
   --           Enclosing_Context fields of the result Elements are set
   --           from In_Unit

   procedure Set_Element_List
     (List             : List_Id;
      Include_Pragmas  : Boolean                := False;
      Starting_Element : Asis.Element           := Asis.Nil_Element;
      Node_Knd         : Node_Kind              := N_Empty;
      Internal_Kind    : Internal_Element_Kinds := Not_An_Element;
      Special_Case     : Special_Cases          := Not_A_Special_Case;
      Norm_Case        : Normalization_Cases    := Is_Not_Normalized;
      In_Unit          : Asis.Compilation_Unit  := Asis.Nil_Compilation_Unit;
      Append           : Boolean                := False);
   --  Does exactly the same as the function N_To_E_List_New, but places
   --  its result into A4G.Asis_Tables.Internal_Asis_Element_Table.
   --
   --  If Append parameter is set ON, the list created as the result of the
   --  call to this procedure is appended to the current content of the
   --  Element Table
   --
   --  ???
   --  It seems that we will have to get rid of functions creating Element
   --  Lists and to build Element lists only with Element Table. Moreover, now
   --  N_To_E_List_New just calls  Set_Element_List with Append OFF and returns
   --  the content of Internal_Asis_Element_Table

   procedure Set_Inherited_Discriminants (Type_Def : Asis.Element);
   --  Provided that Type_Def represents the definition of a derived
   --  type which may inherit discriminants, this procedure creates in
   --  the Element Table the list of declarations representing inherited
   --  discriminants.
   --  Note, that this function may not set properly Node_Field_1,
   --  Is_Part_Of_Implicit and Is_Part_Of_Inherited fields of the result
   --  Elements.

   procedure Set_Inherited_Components
     (Type_Def      : Asis.Element;
      Include_Discs : Boolean := True);
   --  Provided that Type_Def represents the definition of a derived
   --  record type, this procedure creates in
   --  A4G.Asis_Tables.Asis_Element_Table the list of declarations representing
   --  inherited components. If Include_Discs parameter is set ON, this list
   --  also contain discriminants, otherwise it does not. That is, this
   --  procedure does not determine itself whether or not the discriminants are
   --  inherited by the type, it should be done at the caller side.
   --  Note, that this procedure may not set properly Node_Field_1,
   --  Is_Part_Of_Implicit and Is_Part_Of_Inherited fields of the result
   --  Elements.

   procedure Set_Concurrent_Inherited_Components
     (Type_Def      : Asis.Element;
      Include_Discs : Boolean := True);
   --  Similar to the previous Set_Inherited_Components procedure, but woks
   --  on defininitions of derived concurrent types.

   procedure Set_Inherited_Literals (Type_Def : Asis.Element);
   --  Provided that Type_Def represents the definition of a derived
   --  enumeration type, this procedure creates in
   --  A4G.Asis_Tables.Asis_Element_Table the list of enumeration literal
   --  specifications representing inherited literals

   function Discrete_Choice_Node_To_Element_List
     (Choice_List      : List_Id;
      Starting_Element : Asis.Element)
      return Asis.Element_List;
   --  This function is a special variant of the Node_To_Element_List
   --  function, it constructs the ASIS Element list for an Ada
   --  discrete_choice_list. We need a special Note-to-Element list
   --  constructor for discrete_choice_list, because the automatic
   --  determination of the ASIS kinds for the elements of the resulting
   --  ASIS list does not work in this case.
   --
   --  Starting_Element has the same meaning as in general Node-to-Element
   --  and Node-to-Element list constructors.

   function Defining_Id_List_From_Normalized
     (N : Node_Id;
      From_Declaration : Asis.Element)
      return Asis.Defining_Name_List;
   --  This function constructs an (ASIS) list of A_Defining_Identifier
   --  ASIS Elements from a normalized sequence of one-identified
   --  declarations or specifications. N should be of one of the
   --  following kinds:
   --    N_Object_Declaration
   --    N_Number_Declaration
   --    N_Discriminant_Specification
   --    N_Component_Declaration
   --    N_Parameter_Specification
   --    N_Exception_Declaration
   --    N_Formal_Object_Declaration
   --  This function is intended to be used in the implementation of
   --  Asis.Declarations.Names query

   function Normalized_Namet_String (Node : Node_Id) return String;
   --  Returns the string representation of the construct representing by
   --  Node (assuming that Node represents some terminal Ada construct, such
   --  as an identifier) on the base of the information contained in the
   --  front-end Name Table and obtained by the value of the Chars field of
   --  the Node. This representation is "normalized" by capitalizing the first
   --  letter and every letter after underscore (except for some defining names
   --  from Standard, such as ASCII, for theses names all the letters are
   --  converted to upper case)

   function Ureal_Image (N : Node_Id) return String;
   --  Returns the string representation of a value represented by an
   --  N_Real_Literal node.

   function Is_Statement (N : Node_Id) return Boolean;
   --  Checks if N is a statement node.

   function Parenth_Count
     (N          : Node_Id;
      Original_N : Node_Id)
      return       Nat;
   --  This function is the same as Atree.Paren_Count, except that in case of
   --  the argument of a qualified expression, it decreases the level of
   --  parentheses to return the result corresponding to the syntax defined
   --  in RM 4.7(2) (see 9114-002)

   function Get_Next_Configuration_Pragma (N : Node_Id) return Node_Id;
   --  Returns the next configuration pragma node in the list. (If the argument
   --  is a configuration pragma node, returns the argument). If there is no
   --  more configuration pragmas in the list or if N is an empty node, returns
   --  Empty. A caller is responsible for calling this function for list
   --  elements only.

end A4G.Mapping;

Add the ASIS file $i

Add the ASIS file $i


-- RUN: %llvmgcc -c %s -o /dev/null
procedure VCE is
  S : String (1 .. 2);
  B : Character := 'B';
begin
  S := 'A' & B;
end;

Test that the size of a view converted object is determined by the target
type, not the source type.

git-svn-id: 0ff597fd157e6f4fc38580e8d64ab130330d2411@35106 91177308-0d34-0410-b5e6-96231b3b80d8


-----------------------------------------------------------------------
--  components-widgets-gravatars -- Gravatar Components
--  Copyright (C) 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with ASF.Components.Html;
with ASF.Contexts.Faces;
package ASF.Components.Widgets.Gravatars is

   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   function Get_Link (Email  : in String;
                      Secure : in Boolean := False) return String;

   --  ------------------------------
   --  UIGravatar
   --  ------------------------------
   --  The <b>UIGravatar</b> component displays a small image whose link is created
   --  from a user email address.
   type UIGravatar is new ASF.Components.Html.UIHtmlComponent with null record;

   --  Render an image with the source link created from an email address to the Gravatars service.
   overriding
   procedure Encode_Begin (UI      : in UIGravatar;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class);

end ASF.Components.Widgets.Gravatars;

Define the gravatar UI component

Define the gravatar UI component


-----------------------------------------------------------------------
--  wiki-filters-html-tests -- Unit tests for wiki HTML filters
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Tests;

package Wiki.Filters.Html.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   --  Test Find_Tag operation.
   procedure Test_Find_Tag (T : in out Test);

end Wiki.Filters.Html.Tests;

Add a unit test for HTML filter internals


-----------------------------------------------------------------------
--  util-log-locations -- General purpose source file location
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Strings;
package body Util.Log.Locations is

   --  ------------------------------
   --  Create a File_Info record to identify the file whose path is Path
   --  and whose relative path portion starts at Relative_Position.
   --  ------------------------------
   function Create_File_Info (Path              : in String;
                              Relative_Position : in Natural) return File_Info_Access is
   begin
      return new File_Info '(Length       => Path'Length,
                             Path         => Path,
                             Relative_Pos => Relative_Position);
   end Create_File_Info;

   --  ------------------------------
   --  Get the relative path name
   --  ------------------------------
   function Relative_Path (File : in File_Info) return String is
   begin
      return File.Path (File.Relative_Pos .. File.Path'Last);
   end Relative_Path;

   --  ------------------------------
   --  Get the line number
   --  ------------------------------
   function Line (Info : Line_Info) return Natural is
   begin
      return Info.Line;
   end Line;

   --  ------------------------------
   --  Get the column number
   --  ------------------------------
   function Column (Info : Line_Info) return Natural is
   begin
      return Info.Column;
   end Column;

   --  ------------------------------
   --  Get the source file
   --  ------------------------------
   function File (Info : Line_Info) return String is
   begin
      return Info.File.Path;
   end File;

   --  ------------------------------
   --  Create a source line information.
   --  ------------------------------
   function Create_Line_Info (File   : in File_Info_Access;
                              Line   : in Natural;
                              Column : in Natural := 0) return Line_Info is
      Result : Line_Info;
   begin
      Result.Line   := Line;
      Result.Column := Column;
      if File = null then
         Result.File := NO_FILE'Access;
      else
         Result.File := File;
      end if;
      return Result;
   end Create_Line_Info;

   --  ------------------------------
   --  Get a printable representation of the line information using
   --  the format:
   --    <path>:<line>[:<column>]
   --  The path can be reported as relative or absolute path.
   --  The column is optional and reported by default.
   --  ------------------------------
   function To_String (Info     : in Line_Info;
                       Relative : in Boolean := True;
                       Column   : in Boolean := True) return String is
   begin
      if Relative then
         if Column then
            return Relative_Path (Info.File.all) & ":" & Util.Strings.Image (Info.Line)
               & ":" & Util.Strings.Image (Info.Column);
         else
            return Relative_Path (Info.File.all) & ":" & Util.Strings.Image (Info.Line);
         end if;
      else
         if Column then
            return Info.File.Path & ":" & Util.Strings.Image (Info.Line)
               & ":" & Util.Strings.Image (Info.Column);
         else
            return Info.File.Path & ":" & Util.Strings.Image (Info.Line);
         end if;
      end if;
   end To_String;

end Util.Log.Locations;

Implement the package (taken from ASF.Views package implementation)


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . D E F A U L T S                         --
--                                                                          --
--            Copyright (C) 1995-2010, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU  General  Public  License  distributed with ASIS-for-GNAT;  see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  AdaCore                   --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

with Unchecked_Deallocation;

with A4G.A_Osint; use A4G.A_Osint;
with A4G.U_Conv;  use A4G.U_Conv;

with Output;      use Output;

package body A4G.Defaults is

   procedure Free_String is new Unchecked_Deallocation
     (String, String_Access);

   procedure Add_Src_Search_Dir (Dir : String);
   --  Add Dir at the end of the default source file search path.

   procedure Add_Lib_Search_Dir (Dir : String);
   --  Add Dir at the end of the default library (=object+ALI) file search
   --  path.

   ------------------------
   -- Add_Lib_Search_Dir --
   ------------------------

   procedure Add_Lib_Search_Dir (Dir : String) is
   begin
      ASIS_Lib_Search_Directories.Increment_Last;
      ASIS_Lib_Search_Directories.Table (ASIS_Lib_Search_Directories.Last) :=
        new String'(Normalize_Directory_Name (Dir));
   end Add_Lib_Search_Dir;

   ------------------------
   -- Add_Src_Search_Dir --
   ------------------------

   procedure Add_Src_Search_Dir (Dir : String) is
   begin
      ASIS_Src_Search_Directories.Increment_Last;
      ASIS_Src_Search_Directories.Table (ASIS_Src_Search_Directories.Last) :=
        new String'(Normalize_Directory_Name (Dir));
   end Add_Src_Search_Dir;

   --------------
   -- Finalize --
   --------------

   procedure Finalize is
   begin
      --  finalise ASIS_Src_Search_Directories:
      for I in First_Dir_Id .. ASIS_Src_Search_Directories.Last loop
         Free_String (ASIS_Src_Search_Directories.Table (I));
      end loop;

      --  finalize ASIS_Lib_Search_Directories:
      for I in First_Dir_Id .. ASIS_Lib_Search_Directories.Last loop
         Free_String (ASIS_Lib_Search_Directories.Table (I));
      end loop;

      --  finalize ASIS_Tree_Search_Directories
      for I in First_Dir_Id .. ASIS_Tree_Search_Directories.Last loop
         Free_String (ASIS_Tree_Search_Directories.Table (I));
      end loop;
   end Finalize;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
      Search_Path : String_Access;
   begin
      --  just in case:
      Finalize;

      ASIS_Src_Search_Directories.Init;
      ASIS_Lib_Search_Directories.Init;
      ASIS_Tree_Search_Directories.Init;

      --  stroring the defaults for: the code is stolen from Osint
      --  (body, rev. 1.147) and then adjusted

      for Dir_kind in Search_Dir_Kinds loop

         case Dir_kind is
            when Source =>
               Search_Path := Getenv ("ADA_INCLUDE_PATH");
            when Object =>
               Search_Path := Getenv ("ADA_OBJECTS_PATH");
            when Tree =>
               --  There is no environment variable for separate
               --  tree path at the moment;
               exit;
         end case;

         if Search_Path'Length > 0 then
            declare
               Lower_Bound : Positive := 1;
               Upper_Bound : Positive;

            begin
               loop
                  while Lower_Bound <= Search_Path'Last
                    and then Search_Path.all (Lower_Bound) =
                    ASIS_Path_Separator
                  loop
                     Lower_Bound := Lower_Bound + 1;
                  end loop;

                  exit when Lower_Bound > Search_Path'Last;

                  Upper_Bound := Lower_Bound;
                  while Upper_Bound <= Search_Path'Last
                    and then Search_Path.all (Upper_Bound) /=
                    ASIS_Path_Separator
                  loop
                     Upper_Bound := Upper_Bound + 1;
                  end loop;

                  case Dir_kind is
                     when Source =>
                        Add_Src_Search_Dir
                          (Search_Path.all (Lower_Bound .. Upper_Bound - 1));
                     when Object =>
                        Add_Lib_Search_Dir
                          (Search_Path.all (Lower_Bound .. Upper_Bound - 1));
                     when Tree =>
                        exit; --  non implemented yet;
                  end case;

                  Lower_Bound := Upper_Bound + 1;
               end loop;
            end;
         end if;
      end loop;

      --  ???  TEMPORARY SOLUTION: the default objects search path
      --  is also used as the default tree path

      for J in First_Dir_Id .. ASIS_Lib_Search_Directories.Last loop

         ASIS_Tree_Search_Directories.Increment_Last;

         ASIS_Tree_Search_Directories.Table
           (ASIS_Tree_Search_Directories.Last) :=
            new String'(ASIS_Lib_Search_Directories.Table (J).all);

      end loop;

      Free (Search_Path);

   end Initialize;

   -------------------------
   -- Locate_Default_File --
   -------------------------

   function Locate_Default_File
     (File_Name : String_Access;
      Dir_Kind  : Search_Dir_Kinds)
      return String_Access
   is
      function Is_Here_In_Src  (File_Name : String_Access; Dir : Dir_Id)
         return Boolean;
      function Is_Here_In_Lib  (File_Name : String_Access; Dir : Dir_Id)
         return Boolean;
      --  funtion Is_Here_In_Tree (File_Name : String_Access; Dir : Dir_Id)
      --     return Boolean;

      function Is_Here_In_Src  (File_Name : String_Access; Dir : Dir_Id)
         return Boolean
      is
      begin
         return Is_Regular_File (ASIS_Src_Search_Directories.Table (Dir).all
                               & To_String (File_Name));
      end Is_Here_In_Src;

      function Is_Here_In_Lib  (File_Name : String_Access; Dir : Dir_Id)
         return Boolean
      is
      begin
         return Is_Regular_File (ASIS_Lib_Search_Directories.Table (Dir).all
                               & To_String (File_Name));
      end Is_Here_In_Lib;

   begin
      case Dir_Kind is

         when Source =>
            for Dir in First_Dir_Id .. ASIS_Src_Search_Directories.Last loop
               if Is_Here_In_Src (File_Name, Dir) then
                  return new String'
                       (ASIS_Src_Search_Directories.Table (Dir).all
                      & File_Name.all);
               end if;
            end loop;

         when Object =>
            for Dir in First_Dir_Id .. ASIS_Lib_Search_Directories.Last loop
               if Is_Here_In_Lib (File_Name, Dir) then
                  return new String'
                       (ASIS_Lib_Search_Directories.Table (Dir).all
                      & File_Name.all);
               end if;
            end loop;
         when Tree =>
            null; --  non implemented yet;
      end case;

      return null;
   end Locate_Default_File;

   ------------------------
   -- Print_Lib_Defaults --
   ------------------------

   procedure Print_Lib_Defaults is
   begin
      if ASIS_Lib_Search_Directories.Last < First_Dir_Id then
         Write_Str ("   No default library files search path");
         Write_Eol;
      else
         for Dir in First_Dir_Id .. ASIS_Lib_Search_Directories.Last loop
            Write_Str ("   " & ASIS_Lib_Search_Directories.Table (Dir).all);
            Write_Eol;
         end loop;
      end if;
   end Print_Lib_Defaults;

   ---------------------------
   -- Print_Source_Defaults --
   ---------------------------

   procedure Print_Source_Defaults is
   begin
      if ASIS_Src_Search_Directories.Last < First_Dir_Id then
         Write_Str ("   No default source search path");
         Write_Eol;
      else
         for Dir in First_Dir_Id .. ASIS_Src_Search_Directories.Last loop
            Write_Str ("   " & ASIS_Src_Search_Directories.Table (Dir).all);
            Write_Eol;
         end loop;
      end if;
   end Print_Source_Defaults;

   -------------------------
   -- Print_Tree_Defaults --
   -------------------------

   procedure Print_Tree_Defaults is
   begin
      if ASIS_Tree_Search_Directories.Last < First_Dir_Id then
         Write_Str ("   No default tree files search path");
         Write_Eol;
      else
         for Dir in First_Dir_Id .. ASIS_Tree_Search_Directories.Last loop
            Write_Str ("   " & ASIS_Tree_Search_Directories.Table (Dir).all);
            Write_Eol;
         end loop;
      end if;
   end Print_Tree_Defaults;

end A4G.Defaults;

Add the ASIS file $i

Add the ASIS file $i


-- RUN: %llvmgcc -c %s -o /dev/null
procedure Array_Range_Ref is
   A : String (1 .. 3);
   B : String := A (A'RANGE)(1 .. 3);
begin
   null;
end;

Test that ARRAY_RANGE_REF returns an array not an element.

git-svn-id: 0ff597fd157e6f4fc38580e8d64ab130330d2411@35209 91177308-0d34-0410-b5e6-96231b3b80d8


-----------------------------------------------------------------------
--  awa-images-servlets -- Serve files saved in the storage service
--  Copyright (C) 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

package body AWA.Images.Servlets is

   --  ------------------------------
   --  Load the data content that correspond to the GET request and get the name as well
   --  as mime-type and date.
   --  ------------------------------
   overriding
   procedure Load (Server   : in Image_Servlet;
                   Request  : in out ASF.Requests.Request'Class;
                   Name     : out Ada.Strings.Unbounded.Unbounded_String;
                   Mime     : out Ada.Strings.Unbounded.Unbounded_String;
                   Date     : out Ada.Calendar.Time;
                   Data     : out ADO.Blob_Ref) is
   begin
      AWA.Storages.Servlets.Storage_Servlet (Server).Load (Request, Name, Mime, Date, Data);
      Name := Ada.Strings.Unbounded.To_Unbounded_String ("");
   end Load;

end AWA.Images.Servlets;

Implement the Load procedure

Implement the Load procedure


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--           A S I S . D A T A _ D E C O M P O S I T I O N . D E B U G      --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2006, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A  PARTICULAR PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with  ASIS-for-GNAT; see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains routines forming debug images for bstractions
--  declared in Asis.Data_Decomposition.

package Asis.Data_Decomposition.Debug is

   function Debug_Image (RC : Record_Component) return Wide_String;
   function Debug_Image (AC : Array_Component) return Wide_String;

   --  Returns a string value containing implementation-defined debug
   --  information associated with the element.
   --
   --  The return value uses Asis.Text.Delimiter_Image to separate the lines
   --  of multi-line results.  The return value does not end with
   --  Asis.Text.Delimiter_Image.

   function Is_Derived_From_Record (TD : Element) return Boolean;
   function Is_Derived_From_Array  (TD : Element) return Boolean;
   --  The public renaming of
   --  Asis.Data_Decomposition.Aux.Is_Derived_From_Record/
   --  Asis.Data_Decomposition.Aux.Is_Derived_From_Array
   --  May be, we should have it in Asis.Extensions

   function Dimension (Comp : Array_Component) return ASIS_Natural;
   --  The public renaming of
   --  Asis.Data_Decomposition.Set_Get.Dimension
   --  May be, we should have it in Asis.Extensions

--   function Linear_Index
--     (Inds        : Dimension_Indexes;
--      D           : ASIS_Natural;
--      Ind_Lengths : Dimention_Length;
--      Conv        : Convention_Id := Convention_Ada)
--      return Asis.ASIS_Natural;

--   function De_Linear_Index
--     (Index       : Asis.ASIS_Natural;
--      D           : ASIS_Natural;
--      Ind_Lengths : Dimention_Length;
--      Conv        : Convention_Id := Convention_Ada)
--      return Dimension_Indexes;
   --  The public renaming of
   --  Asis.Data_Decomposition.Aux.Linear_Index and
   --  Asis.Data_Decomposition.Aux.De_Linear_Index

end Asis.Data_Decomposition.Debug;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  asf-rest-operation -- REST API Operation Definition
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
generic
   Handler    : Operation_Access;
   Method     : Method_Type := GET;
   URI        : String;
   Permission : Security.Permissions.Permission_Index := Security.Permissions.NONE;
package ASF.Rest.Operation is

   function Definition return Descriptor_Access;

end ASF.Rest.Operation;

Define new generic package for the REST API definition


-----------------------------------------------------------------------
--  mat-expressions -- Expressions for memory slot selection
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with MAT.Types;
with MAT.Memory;
package body MAT.Expressions is

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Util.Refs.Ref_Entity with
                                      Kind => N_NOT, Expr => Expr.Node);
      return Result;
   end Create_Not;

end MAT.Expressions;

Implement the Create_Not operation

Implement the Create_Not operation


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                        A 4 G . S P A N _ E N D                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-1999, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

with Asis;  use Asis;

with Types; use Types;

package A4G.Span_End is

   --  This package encapsulates queries needed to find the end of Element's
   --  Span (as the pointer to the Source Buffer).

   function Set_Image_End (E : Asis.Element) return Source_Ptr;
   --  This is the main function in this package. It returns the pointer
   --  to the last character of the given element in the Source Buffer

end A4G.Span_End;

Add the ASIS file $i

Add the ASIS file $i


-- RUN: %llvmgcc -c %s -o /dev/null
function Switch (N : Integer) return Integer is
begin
   case N is
      when Integer'First .. -1 =>
         return -1;
      when 0 =>
         return 0;
      when others =>
         return 1;
   end case;
end;

Test handling of switches with wide case ranges.

git-svn-id: 0ff597fd157e6f4fc38580e8d64ab130330d2411@35279 91177308-0d34-0410-b5e6-96231b3b80d8


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--       A S I S . D A T A _ D E C O M P O S I T I O N . S E T _ G E T      --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2005, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains access and update routines for abstractions
--  declared in Asis.Data_Decomposition.
--
--  It also contains routines for creating lists of record and array
--  components

with A4G.Asis_Tables; use A4G.Asis_Tables;
with A4G.DDA_Aux;     use A4G.DDA_Aux;

with Table;

private package Asis.Data_Decomposition.Set_Get is

   --  Tables used to create query results which are of list types:

   package Record_Component_Table is new Table.Table (
     Table_Component_Type => Record_Component,
     Table_Index_Type     => Asis.ASIS_Natural,
     Table_Low_Bound      => 1,
     Table_Initial        => 10,
     Table_Increment      => 100,
     Table_Name           => "Record_Componnet_List");

   RC_Table : Record_Component_Table.Table_Ptr renames
      Record_Component_Table.Table;

   Def_N_Table : Asis_Element_Table.Table_Ptr renames
      Asis_Element_Table.Table;

   Nil_Record_Component_List : Record_Component_List (1 .. 0);
   --  Nil constant for Record_Component_List is not provided in the
   --  Asis.Data_Decomposition package.

   Parent_Type_Definition : Element;
   --  Global variable used to store the type definition from which componnets
   --  are extracted

   Record_Type_Entity : Entity_Id;
   --  Global variable used to store the type entity defining the type of
   --  a record. This is a type entity which actually defines the
   --  type, that is, it may be an implicit type as well

   procedure Set_Parent_Type_Definition (E : Element);
   --  Sets Parent_Type_Definition (Currently this is a trivial assignment,
   --  but we would better keep procedural interface in case if something
   --  more smart is really required here.

   procedure Set_Record_Type_Entity (RC : Record_Component);
   --  Sets Record_Type_Entity for RC, if Is_Record (RC)

   procedure Set_Record_Type_Entity (AC : Array_Component);
   --  Sets Record_Type_Entity for AC, if Is_Record (AC)

   procedure Set_Record_Type_Entity;
   --  Sets Record_Type_Entity by using the valuse of Parent_Type_Definition
   --  global variable

   --  Access functions to Record_Component fields:

   subtype RC is Record_Component;

   function Parent_Record_Type (Comp : RC) return Asis.Declaration;
   function Component_Name     (Comp : RC) return Asis.Defining_Name;
   function Is_Record_Comp     (Comp : RC) return Boolean;
   function Is_Array_Comp      (Comp : RC) return Boolean;
   function Parent_Discrims    (Comp : RC) return Discrim_List;

   function Get_Type_Entity    (Comp : RC) return Entity_Id;
   --  Returns type Entity describing the subtype of the component.
   --  It may be implicit type as well

   function Get_Comp_Entity (Comp : RC) return Entity_Id;
   --  Returns the Entity Id of the given record component

   function Get_Record_Entity (Comp : RC) return Entity_Id;
   --  Returns the Entity Id of the enclosing record type declaration
   --  for a given component (it may be a type derived from a record type)

   --  Array Components:

   subtype AC is Array_Component;

   function Parent_Array_Type     (Comp : AC) return Asis.Declaration;
   function Is_Record_Comp        (Comp : AC) return Boolean;
   function Is_Array_Comp         (Comp : AC) return Boolean;
   function Dimension             (Comp : AC) return ASIS_Natural;
   function Parent_Discrims       (Comp : AC) return Discrim_List;

   function Get_Array_Type_Entity (Comp : AC) return  Entity_Id;
   --  Returns the Entity_Id for the array type from which this array
   --  component is extracted. It may be the Id of some implicit array type
   --  as well

   procedure Set_Parent_Discrims (Comp : in out AC; Discs : Discrim_List);
   --  Sets Discs as Parent_Discrims for Comp. In case if Discs is
   --  Null_Discrims sets Parent_Discrims as null.

   type List_Kinds is (New_List, Append);
   --  The way of creating a list in Element or Component Table

   procedure Set_Named_Components (E : Element; List_Kind : List_Kinds);
   --  Stores all the A_Defining_Identifier components contained in E in
   --  Asis_Element_Table. If List_Kind is set to New_List, it resets
   --  Asis_Element_Table before putting any information in it. If List_Kind
   --  is set to Append, the Table is not reset, and the created list
   --  is appended to the list already stored in the table.

   procedure Set_All_Named_Components (E : Element);
   --  Provided that E is a record type definition or a definition of a
   --  derived type derived from some record type, this function
   --  stores all the A_Defining_Identifier Elements defining the
   --  componnets for this type in Asis_Element_Table. Before doing this,
   --  the procedure resets Asis_Element_Table.

   procedure Set_Record_Components_From_Names
     (Parent_First_Bit : ASIS_Natural  := 0;
      Data_Stream      : Portable_Data := Nil_Portable_Data;
      Discriminants    : Boolean       := False);
   --  Supposing that an appropriate list of component defining names is set
   --  in the Asis_Element_Table, this procedure converts them into
   --  the corresponding list of record componnets in Record_Component_Table.
   --
   --  Parent_First_Bit is needed to compute the first bit and position of
   --  the component that is extracted from another (record or array)
   --  component. Usually everything is alligned at least bytewise, but in case
   --  if representation clauses are used to create heavily packed data
   --  structure, we may need to know where to start to compute the component
   --  beginning
   --
   --  If Data_Stream parameter is set, it is used to define which
   --  components from the list set in Asis_Element_Table should be
   --  presented in the result.
   --
   --  Discriminants flag is used to indicate the case when (only)
   --  discriminant components should be constructed, in this case no
   --  discriminant constraint (explicit or default) should be taken into
   --  account (they may be dynamic in case of A_Complex_Dynamic_Model type).

   function Set_Array_Componnet
     (Array_Type_Definition      : Element;
      Enclosing_Record_Component : Record_Component := Nil_Record_Component;
      Parent_Indication          : Element          := Nil_Element;
      Parent_Discriminants       : Discrim_List     := Null_Discrims;
      Parent_First_Bit_Offset    : ASIS_Natural     := 0;
      Dynamic_Array              : Boolean          := False)
      return Array_Component;
   --  Sets and returns an Array_Component value. Array_Type_Definition
   --  parameter should represent a (constrained or unconstrained) array type
   --  definition or a derived type definition for which an ancestor type is
   --  an array type. The returned value represent the component of this array
   --  type. Enclosing_Record_Component is set when the array componnet to be
   --  created is a part of some Record_Component, in this case the
   --  corresponding component definition may contain index constraints.
   --  Parent_Indication is set when the array componnet to be created is a
   --  part of some other array component, in this case the corresponding
   --  component subtype indication may contain an index constraint
   --  ???? Documentation needs revising!!!

end Asis.Data_Decomposition.Set_Get;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  awa-wikis-servlets -- Serve files saved in the storage service
--  Copyright (C) 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Calendar;

with Util.Log.Loggers;

with ADO.Objects;

with ASF.Streams;

with AWA.Wikis.Modules;
package body AWA.Wikis.Servlets is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Wikis.Servlets");

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   overriding
   procedure Initialize (Server  : in out Image_Servlet;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Called by the server (via the service method) to allow a servlet to handle
   --  a GET request.
   --
   --  Overriding this method to support a GET request also automatically supports
   --  an HTTP HEAD request. A HEAD request is a GET request that returns no body
   --  in the response, only the request header fields.
   --
   --  When overriding this method, read the request data, write the response headers,
   --  get the response's writer or output stream object, and finally, write the
   --  response data. It's best to include content type and encoding.
   --  When using a PrintWriter object to return the response, set the content type
   --  before accessing the PrintWriter object.
   --
   --  The servlet container must write the headers before committing the response,
   --  because in HTTP the headers must be sent before the response body.
   --
   --  Where possible, set the Content-Length header (with the
   --  Response.Set_Content_Length method), to allow the servlet container
   --  to use a persistent connection to return its response to the client,
   --  improving performance. The content length is automatically set if the entire
   --  response fits inside the response buffer.
   --
   --  When using HTTP 1.1 chunked encoding (which means that the response has a
   --  Transfer-Encoding header), do not set the Content-Length header.
   --
   --  The GET method should be safe, that is, without any side effects for which
   --  users are held responsible. For example, most form queries have no side effects.
   --  If a client request is intended to change stored data, the request should use
   --  some other HTTP method.
   --
   --  The GET method should also be idempotent, meaning that it can be safely repeated.
   --  Sometimes making a method safe also makes it idempotent. For example, repeating
   --  queries is both safe and idempotent, but buying a product online or modifying
   --  data is neither safe nor idempotent.
   --
   --  If the request is incorrectly formatted, Do_Get  returns an HTTP "Bad Request"
   --  ------------------------------
   overriding
   procedure Do_Get (Server   : in Image_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (Server);

      Data    : ADO.Blob_Ref;
      Mime    : Ada.Strings.Unbounded.Unbounded_String;
      Date    : Ada.Calendar.Time;
      Module  : constant AWA.Wikis.Modules.Wiki_Module_Access := Wikis.Modules.Get_Wiki_Module;
      Wiki    : constant String := Request.Get_Path_Parameter (1);
      File    : constant String := Request.Get_Path_Parameter (2);
      Name    : constant String := Request.Get_Path_Parameter (3);
      Wiki_Id : ADO.Identifier;
      File_Id : ADO.Identifier;
   begin
      Wiki_Id := ADO.Identifier'Value (Wiki);
      File_Id := ADO.Identifier'Value (File);

      Log.Info ("GET storage file {0}/{1}/{2}", Wiki, File, Name);
      Module.Load_Image (Wiki_Id  => Wiki_Id,
                         Image_Id => File_Id,
                         Mime     => Mime,
                         Date     => Date,
                         Into     => Data);

      --  Send the file.
      Response.Set_Content_Type (Ada.Strings.Unbounded.To_String (Mime));
      declare
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
      begin
         Output.Write (Data.Value.Data);
      end;

   exception
      when ADO.Objects.NOT_FOUND | Constraint_Error =>
         Log.Info ("Storage file {0}/{1}/{2} not found", Wiki, File, Name);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
   end Do_Get;

end AWA.Wikis.Servlets;

Implement the Image_Servlet type and operations


-----------------------------------------------------------------------
--  awa-wikis-previews -- Wiki preview management
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with ASF.Applications;

with AWA.Modules;
with AWA.Jobs.Services;
with AWA.Wikis.Modules;
with AWA.Wikis.Models;

--  == Wiki Preview Module ==
--  The <tt>AWA.Wikis.Previews</tt> package implements a preview image generation for a wiki page.
--  This module is optional, it is possible to use the wikis without preview support.  When the
--  module is registered, it listens to wiki page lifecycle events.  When a new wiki content is
--  changed, it triggers a job to make the preview.  The preview job uses the
--  <tt>wkhtmotoimage</tt> external program to make the preview image.
package AWA.Wikis.Previews is

   --  The name under which the module is registered.
   NAME : constant String := "wiki-previews";

   --  The worker procedure that performs the preview job.
   procedure Preview_Worker (Job : in out AWA.Jobs.Services.Abstract_Job_Type'Class);

   --  Preview job definition.
   package Preview_Job_Definition is new AWA.Jobs.Services.Work_Definition (Preview_Worker'Access);

   --  ------------------------------
   --  Preview wiki module
   --  ------------------------------
   type Preview_Module is new AWA.Modules.Module
     and AWA.Wikis.Modules.Wiki_Lifecycle.Listener with private;
   type Preview_Module_Access is access all Preview_Module'Class;

   --  Initialize the preview wiki module.
   overriding
   procedure Initialize (Plugin : in out Preview_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  The `On_Create` procedure is called by `Notify_Create` to notify the creation of the page.
   overriding
   procedure On_Create (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the page.
   overriding
   procedure On_Update (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion of the page.
   overriding
   procedure On_Delete (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

private

   type Preview_Module is new AWA.Modules.Module
     and AWA.Wikis.Modules.Wiki_Lifecycle.Listener with null record;

end AWA.Wikis.Previews;

Define the wiki Previews package module for the generation of wiki page thumbnail preview


-----------------------------------------------------------------------
--  util-properties-json -- read json files into properties
--  Copyright (C) 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Serialize.IO.JSON;
with Util.Stacks;
with Util.Beans.Objects;
package body Util.Properties.JSON is

   type Natural_Access is access all Natural;

   package Length_Stack is new Util.Stacks (Element_Type        => Natural,
                                            Element_Type_Access => Natural_Access);

   type Parser is new Util.Serialize.IO.JSON.Parser with record
      Base_Name        : Ada.Strings.Unbounded.Unbounded_String;
      Lengths          : Length_Stack.Stack;
      Separator        : Ada.Strings.Unbounded.Unbounded_String;
      Separator_Length : Natural;
   end record;

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String) is
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Name);
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Handler.Separator);
         Length_Stack.Push (Handler.Lengths);
         Length_Stack.Current (Handler.Lengths).all := Name'Length + Handler.Separator_Length;
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String) is
      Len : constant Natural := Ada.Strings.Unbounded.Length (Handler.Base_Name);
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Delete (Handler.Base_Name,
                                       Len - Name'Length - Handler.Separator_Length + 1, Len);
      end if;
   end Finish_Object;

   --  -----------------------
   --  Parse the JSON content and put the flattened content in the property manager.
   --  -----------------------
   procedure Parse_JSON (Manager : in out Util.Properties.Manager'Class;
                         Content : in String;
                         Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with null record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                      Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
   begin
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse_String (Content);
   end Parse_JSON;

   --  -----------------------
   --  Read the JSON file into the property manager.
   --  The JSON content is flatten into Flatten the JSON content and add the properties.
   --  -----------------------
   procedure Read_JSON (Manager : in out Util.Properties.Manager'Class;
                        Path    : in String;
                        Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with null record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                      Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
   begin
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse (Path);
   end Read_JSON;

end Util.Properties.JSON;

Implement reading JSON content and putting it in property manager


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--   A S I S . D A T A _ D E C O M P O S I T I O N . E X T E N S I O N S    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2010, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;
with System;                          use System;

with Asis.Data_Decomposition.Vcheck;  use Asis.Data_Decomposition.Vcheck;
with Asis.Data_Decomposition.Set_Get; use Asis.Data_Decomposition.Set_Get;
with Asis.Errors;                     use Asis.Errors;
with Asis.Exceptions;                 use Asis.Exceptions;
with Asis.Set_Get;                    use Asis.Set_Get;

with A4G.DDA_Aux;                     use A4G.DDA_Aux;
with A4G.Vcheck;                      use A4G.Vcheck;

with Einfo;                           use Einfo;
with Namet;                           use Namet;
with Uintp;                           use Uintp;
with Urealp;                          use Urealp;

package body Asis.Data_Decomposition.Extensions  is

   Package_Name : constant String := "Asis.Data_Decomposition.Extensions.";

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Write_Real_To_Buffer (U : Ureal);
   --  Puts nnn/ddd to Name_Buffer, where nnn and ddd are integer values of
   --  the normalized numerator and denominator of the given real value.
   --  This procedure is supposed to be used to output images of positive
   --  real values only, so it assumes, that nnn is always positive.

   procedure Add_Uint_To_Buffer (U : Uint);
   --  Add image of universal integer to Name_Buffer, updating Name_Len
   --  (This procedure is the simplified version of the local procedure
   --  Exp_Dbug.Add_Uint_To_Buffer - it always consider its argument
   --  being positive)

   ------------------------
   -- Add_Uint_To_Buffer --
   ------------------------

   procedure Add_Uint_To_Buffer (U : Uint) is
   begin
      UI_Image (U, Decimal);
      Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
   end Add_Uint_To_Buffer;

   -------------------------------
   -- Component_Name_Definition --
   -------------------------------

   function Component_Name_Definition
     (Component : Record_Component)
      return      Asis.Declaration
   is
      Result : Asis.Element;
   begin
      Check_Validity (Component, Package_Name & "Component_Name_Definition");

      if Is_Nil (Component) then
         Raise_ASIS_Inappropriate_Component
           (Diagnosis      => Package_Name & "Component_Name_Definition",
            Component_Kind => Rec);
      end if;

      Result := Component_Name (Component);

      return Result;

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Component_Name_Definition");

         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Component_Name_Definition",
            Ex          => Ex);
   end Component_Name_Definition;

   --------------------------
   -- Delta_Value (String) --
   --------------------------

   function Delta_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                String
   is
      Arg_Node      : Node_Id;
      Res_Ureal     : Ureal;
   begin
      Check_Validity
        (Fixed_Point_Subtype, Package_Name & "Delta_Value (String)");

      Arg_Node := R_Node (Fixed_Point_Subtype);

      if not (Int_Kind (Fixed_Point_Subtype) = A_Defining_Identifier and then
              Is_Fixed_Point_Type (Arg_Node))
      then
         Raise_ASIS_Inappropriate_Element
           (Diagnosis  => Package_Name & "Delta_Value (String)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype));
      end if;

      Res_Ureal := Einfo.Delta_Value (Arg_Node);

      Write_Real_To_Buffer (Res_Ureal);

      return Namet.Name_Buffer (1 .. Namet.Name_Len);

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Delta_Value (String)",
               Argument   => Fixed_Point_Subtype);
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Delta_Value (String)",
           Ex          => Ex,
           Arg_Element => Fixed_Point_Subtype);
   end Delta_Value;

   ----------------------------
   -- Delta_Value (Fraction) --
   ----------------------------

   function Delta_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                Fraction
   is
      Arg_Node  : Node_Id;
      Res_Ureal : Ureal;

      Result    : Fraction;

   begin
      Check_Validity
        (Fixed_Point_Subtype, Package_Name & "Delta_Value (Fraction)");

      Arg_Node := R_Node (Fixed_Point_Subtype);

      if not (Int_Kind (Fixed_Point_Subtype) = A_Defining_Identifier and then
              Is_Fixed_Point_Type (Arg_Node))
      then
         Raise_ASIS_Inappropriate_Element
           (Diagnosis  => Package_Name & "Delta_Value (Fraction)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype));
      end if;

      Res_Ureal := Einfo.Delta_Value (Arg_Node);

      Result.Num   := UI_To_Aint (Norm_Num (Res_Ureal));
      Result.Denum := UI_To_Aint (Norm_Den (Res_Ureal));

      return Result;

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Delta_Value (Fraction)",
               Argument   => Fixed_Point_Subtype);
         end if;

         raise;
      when Invalid_Data =>
         Raise_ASIS_Inappropriate_Element
           (Diagnosis  => Package_Name & "Delta_Value (Fraction)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype),
            Status     => Data_Error);
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Delta_Value (Fraction)",
           Ex          => Ex,
           Arg_Element => Fixed_Point_Subtype);
   end Delta_Value;

   ------------------
   -- Digits_Value --
   ------------------

   function Digits_Value
     (Floating_Point_Subtype : Asis.Element)
      return                   ASIS_Natural
   is
      Arg_Node      : Node_Id;
   begin
      Check_Validity (Floating_Point_Subtype, Package_Name & "Digits_Value");

      Arg_Node := R_Node (Floating_Point_Subtype);

      if not (Int_Kind (Floating_Point_Subtype) = A_Defining_Identifier
            and then
             (Is_Decimal_Fixed_Point_Type (Arg_Node) or else
              Is_Floating_Point_Type (Arg_Node)))
      then
         Raise_ASIS_Inappropriate_Element
           (Package_Name & "Digits_Value",
            Wrong_Kind => Int_Kind (Floating_Point_Subtype));
      end if;

      return ASIS_Natural (UI_To_Int (Einfo.Digits_Value (Arg_Node)));

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Digits_Value",
               Argument   => Floating_Point_Subtype);
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Digits_Value",
           Ex          => Ex,
           Arg_Element => Floating_Point_Subtype);
   end Digits_Value;

   --------------------------
   --  Portable_Data_Value --
   --------------------------

   function Portable_Data_Value
     (Value : Constrained_Subtype)
      return  Portable_Data
   is

      Local_Value : aliased constant Constrained_Subtype := Value;
      for Local_Value'Alignment use Standard'Maximum_Alignment;
      --  We force the maximum alignment for Local_Value to make it
      --  compatible with maximum alignment set for Portable_Data
      --  in the spec of Asis.Data_Decomposition

      subtype Result_Portable_Data is
         Portable_Data (1 .. (Constrained_Subtype'Object_Size + 7) / 8);

      type Result_Portable_Data_Access is access Result_Portable_Data;

      function To_Result_Portable_Data_Access is new
         Ada.Unchecked_Conversion (Address, Result_Portable_Data_Access);

      Result : constant Result_Portable_Data_Access :=
         To_Result_Portable_Data_Access (Local_Value'Address);

   begin

      return Result.all;
   exception
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Portable_Data_Value");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Portable_Data_Value",
           Ex          => Ex);
   end Portable_Data_Value;

   -----------------
   -- Scale_Value --
   -----------------

   function Scale_Value
     (Desimal_Fixed_Point_Subtype : Asis.Element)
      return                        ASIS_Natural
   is
      Arg_Node      : Node_Id;

   begin
      Check_Validity
        (Desimal_Fixed_Point_Subtype, Package_Name & "Scale_Value");

      Arg_Node := R_Node (Desimal_Fixed_Point_Subtype);

      if not (Int_Kind (Desimal_Fixed_Point_Subtype) = A_Defining_Identifier
            and then
              Is_Decimal_Fixed_Point_Type (Arg_Node))
      then
         Raise_ASIS_Inappropriate_Element
           (Package_Name & "Scale_Value",
            Wrong_Kind => Int_Kind (Desimal_Fixed_Point_Subtype));
      end if;

      return ASIS_Natural (UI_To_Int (Einfo.Scale_Value (Arg_Node)));

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Scale_Value",
               Argument   => Desimal_Fixed_Point_Subtype);
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Scale_Value",
           Ex          => Ex,
           Arg_Element => Desimal_Fixed_Point_Subtype);
   end Scale_Value;

   --------------------------
   -- Small_Value (String) --
   --------------------------

   function Small_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                String
   is
      Arg_Node  : Node_Id;
      Res_Ureal : Ureal;

   begin
      Check_Validity
        (Fixed_Point_Subtype, Package_Name & "Small_Value (String)");

      Arg_Node := R_Node (Fixed_Point_Subtype);

      if not (Int_Kind (Fixed_Point_Subtype) = A_Defining_Identifier and then
              Is_Fixed_Point_Type (Arg_Node))
      then
         Raise_ASIS_Inappropriate_Element
           (Package_Name & "Small_Value (String)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype));
      end if;

      Res_Ureal := Einfo.Small_Value (Arg_Node);

      Write_Real_To_Buffer (Res_Ureal);

      return Namet.Name_Buffer (1 .. Namet.Name_Len);

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Small_Value (String)",
               Argument   => Fixed_Point_Subtype);
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Small_Value (String)",
           Ex          => Ex,
           Arg_Element => Fixed_Point_Subtype);
   end Small_Value;

   ----------------------------
   -- Small_Value (Fraction) --
   ----------------------------

   function Small_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                Fraction
   is
      Arg_Node  : Node_Id;
      Res_Ureal : Ureal;

      Result    : Fraction;
   begin
      Check_Validity
        (Fixed_Point_Subtype, Package_Name & "Small_Value (Fraction)");

      Arg_Node := R_Node (Fixed_Point_Subtype);

      if not (Int_Kind (Fixed_Point_Subtype) = A_Defining_Identifier and then
              Is_Fixed_Point_Type (Arg_Node))
      then
         Raise_ASIS_Inappropriate_Element
           (Package_Name & "Small_Value (Fraction)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype));
      end if;

      Res_Ureal := Einfo.Small_Value (Arg_Node);

      Result.Num   := UI_To_Aint (Norm_Num (Res_Ureal));
      Result.Denum := UI_To_Aint (Norm_Den (Res_Ureal));

      return Result;

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Small_Value (Fraction)",
               Argument   => Fixed_Point_Subtype);
         end if;

         raise;

      when Invalid_Data =>
         Raise_ASIS_Inappropriate_Element
           (Diagnosis  => Package_Name & "Small_Value (Fraction)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype),
            Status     => Data_Error);
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Small_Value (Fraction)",
           Ex          => Ex,
           Arg_Element => Fixed_Point_Subtype);
   end Small_Value;

   --------------------------
   -- Write_Real_To_Buffer --
   --------------------------

   procedure Write_Real_To_Buffer (U : Ureal) is
   begin
      Namet.Name_Len := 0;

      Add_Uint_To_Buffer (Norm_Num (U));
      Add_Str_To_Name_Buffer ("/");
      Add_Uint_To_Buffer (Norm_Den (U));
   end Write_Real_To_Buffer;

end Asis.Data_Decomposition.Extensions;

Add the ASIS file $i

Add the ASIS file $i