Subversion Repositories openrisc_me

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT LIBRARY COMPONENTS                          --

--                                                                          --

--                          G N A T . R E G P A T                           --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--               Copyright (C) 1986 by University of Toronto.               --

--                      Copyright (C) 1999-2009, AdaCore                    --

--                                                                          --

-- 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 Soft- --

-- ware  Foundation;  either version 2,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- 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 GNAT;  see file COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- As a special exception,  if other files  instantiate  generics from this --

-- unit, or you link  this unit with other files  to produce an executable, --

-- this  unit  does not  by itself cause  the resulting  executable  to  be --

-- covered  by the  GNU  General  Public  License.  This exception does not --

-- however invalidate  any other reasons why  the executable file  might be --

-- covered by the  GNU Public License.                                      --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

--  This is an altered Ada 95 version of the original V8 style regular

--  expression library written in C by Henry Spencer. Apart from the

--  translation to Ada, the interface has been considerably changed to

--  use the Ada String type instead of C-style nul-terminated strings.

--  Beware that some of this code is subtly aware of the way operator

--  precedence is structured in regular expressions. Serious changes in

--  regular-expression syntax might require a total rethink.

with System.IO;               use System.IO;

with Ada.Characters.Handling; use Ada.Characters.Handling;

with Ada.Unchecked_Conversion;

package body System.Regpat is

   MAGIC : constant Character := Character'Val (10#0234#);

   --  The first byte of the regexp internal "program" is actually

   --  this magic number; the start node begins in the second byte.

   --

   --  This is used to make sure that a regular expression was correctly

   --  compiled.

   ----------------------------

   -- Implementation details --

   ----------------------------

   --  This is essentially a linear encoding of a nondeterministic

   --  finite-state machine, also known as syntax charts or

   --  "railroad normal form" in parsing technology.

   --  Each node is an opcode plus a "next" pointer, possibly plus an

   --  operand. "Next" pointers of all nodes except BRANCH implement

   --  concatenation; a "next" pointer with a BRANCH on both ends of it

   --  is connecting two alternatives.

   --  The operand of some types of node is a literal string; for others,

   --  it is a node leading into a sub-FSM. In particular, the operand of

   --  a BRANCH node is the first node of the branch.

   --  (NB this is *not* a tree structure:  the tail of the branch connects

   --  to the thing following the set of BRANCHes).

   --  You can see the exact byte-compiled version by using the Dump

   --  subprogram. However, here are a few examples:

   --  (a|b):  1 : MAGIC

   --          2 : BRANCH  (next at  10)

   --          5 :    EXACT  (next at  18)   operand=a

   --         10 : BRANCH  (next at  18)

   --         13 :    EXACT  (next at  18)   operand=b

   --         18 : EOP  (next at 0)

   --

   --  (ab)*:  1 : MAGIC

   --          2 : CURLYX  (next at  26)  { 0, 32767}

   --          9 :    OPEN 1  (next at  13)

   --         13 :       EXACT  (next at  19)   operand=ab

   --         19 :    CLOSE 1  (next at  23)

   --         23 :    WHILEM  (next at 0)

   --         26 : NOTHING  (next at  29)

   --         29 : EOP  (next at 0)

   --  The opcodes are:

   type Opcode is

      --  Name          Operand?  Meaning

     (EOP,        -- no        End of program

      MINMOD,     -- no        Next operator is not greedy

      --  Classes of characters

      ANY,        -- no        Match any one character except newline

      SANY,       -- no        Match any character, including new line

      ANYOF,      -- class     Match any character in this class

      EXACT,      -- str       Match this string exactly

      EXACTF,     -- str       Match this string (case-folding is one)

      NOTHING,    -- no        Match empty string

      SPACE,      -- no        Match any whitespace character

      NSPACE,     -- no        Match any non-whitespace character

      DIGIT,      -- no        Match any numeric character

      NDIGIT,     -- no        Match any non-numeric character

      ALNUM,      -- no        Match any alphanumeric character

      NALNUM,     -- no        Match any non-alphanumeric character

      --  Branches

      BRANCH,     -- node      Match this alternative, or the next

      --  Simple loops (when the following node is one character in length)

      STAR,       -- node      Match this simple thing 0 or more times

      PLUS,       -- node      Match this simple thing 1 or more times

      CURLY,      -- 2num node Match this simple thing between n and m times.

      --  Complex loops

      CURLYX,     -- 2num node Match this complex thing {n,m} times

      --                       The nums are coded on two characters each

      WHILEM,     -- no        Do curly processing and see if rest matches

      --  Matches after or before a word

      BOL,        -- no        Match "" at beginning of line

      MBOL,       -- no        Same, assuming multiline (match after \n)

      SBOL,       -- no        Same, assuming single line (don't match at \n)

      EOL,        -- no        Match "" at end of line

      MEOL,       -- no        Same, assuming multiline (match before \n)

      SEOL,       -- no        Same, assuming single line (don't match at \n)

      BOUND,      -- no        Match "" at any word boundary

      NBOUND,     -- no        Match "" at any word non-boundary

      --  Parenthesis groups handling

      REFF,       -- num       Match some already matched string, folded

      OPEN,       -- num       Mark this point in input as start of #n

      CLOSE);     -- num       Analogous to OPEN

   for Opcode'Size use 8;

   --  Opcode notes:

   --  BRANCH

   --    The set of branches constituting a single choice are hooked

   --    together with their "next" pointers, since precedence prevents

   --    anything being concatenated to any individual branch. The

   --    "next" pointer of the last BRANCH in a choice points to the

   --    thing following the whole choice. This is also where the

   --    final "next" pointer of each individual branch points; each

   --    branch starts with the operand node of a BRANCH node.

   --  STAR,PLUS

   --    '?', and complex '*' and '+', are implemented with CURLYX.

   --    branches. Simple cases (one character per match) are implemented with

   --    STAR and PLUS for speed and to minimize recursive plunges.

   --  OPEN,CLOSE

   --    ...are numbered at compile time.

   --  EXACT, EXACTF

   --    There are in fact two arguments, the first one is the length (minus

   --    one of the string argument), coded on one character, the second

   --    argument is the string itself, coded on length + 1 characters.

   --  A node is one char of opcode followed by two chars of "next" pointer.

   --  "Next" pointers are stored as two 8-bit pieces, high order first. The

   --  value is a positive offset from the opcode of the node containing it.

   --  An operand, if any, simply follows the node. (Note that much of the

   --  code generation knows about this implicit relationship.)

   --  Using two bytes for the "next" pointer is vast overkill for most

   --  things, but allows patterns to get big without disasters.

   -----------------------

   -- Character classes --

   -----------------------

   --  This is the implementation for character classes ([...]) in the

   --  syntax for regular expressions. Each character (0..256) has an

   --  entry into the table. This makes for a very fast matching

   --  algorithm.

   type Class_Byte is mod 256;

   type Character_Class is array (Class_Byte range 0 .. 31) of Class_Byte;

   type Bit_Conversion_Array is array (Class_Byte range 0 .. 7) of Class_Byte;

   Bit_Conversion : constant Bit_Conversion_Array :=

                      (1, 2, 4, 8, 16, 32, 64, 128);

   type Std_Class is (ANYOF_NONE,

                      ANYOF_ALNUM,   --  Alphanumeric class [a-zA-Z0-9]

                      ANYOF_NALNUM,

                      ANYOF_SPACE,   --  Space class [ \t\n\r\f]

                      ANYOF_NSPACE,

                      ANYOF_DIGIT,   --  Digit class [0-9]

                      ANYOF_NDIGIT,

                      ANYOF_ALNUMC,  --  Alphanumeric class [a-zA-Z0-9]

                      ANYOF_NALNUMC,

                      ANYOF_ALPHA,   --  Alpha class [a-zA-Z]

                      ANYOF_NALPHA,

                      ANYOF_ASCII,   --  Ascii class (7 bits) 0..127

                      ANYOF_NASCII,

                      ANYOF_CNTRL,   --  Control class

                      ANYOF_NCNTRL,

                      ANYOF_GRAPH,   --  Graphic class

                      ANYOF_NGRAPH,

                      ANYOF_LOWER,   --  Lower case class [a-z]

                      ANYOF_NLOWER,

                      ANYOF_PRINT,   --  printable class

                      ANYOF_NPRINT,

                      ANYOF_PUNCT,   --

                      ANYOF_NPUNCT,

                      ANYOF_UPPER,   --  Upper case class [A-Z]

                      ANYOF_NUPPER,

                      ANYOF_XDIGIT,  --  Hexadecimal digit

                      ANYOF_NXDIGIT

                      );

   procedure Set_In_Class

     (Bitmap : in out Character_Class;

      C      : Character);

   --  Set the entry to True for C in the class Bitmap

   function Get_From_Class

     (Bitmap : Character_Class;

      C      : Character) return Boolean;

   --  Return True if the entry is set for C in the class Bitmap

   procedure Reset_Class (Bitmap : out Character_Class);

   --  Clear all the entries in the class Bitmap

   pragma Inline (Set_In_Class);

   pragma Inline (Get_From_Class);

   pragma Inline (Reset_Class);

   -----------------------

   -- Local Subprograms --

   -----------------------

   function "=" (Left : Character; Right : Opcode) return Boolean;

   function Is_Alnum (C : Character) return Boolean;

   --  Return True if C is an alphanum character or an underscore ('_')

   function Is_White_Space (C : Character) return Boolean;

   --  Return True if C is a whitespace character

   function Is_Printable (C : Character) return Boolean;

   --  Return True if C is a printable character

   function Operand (P : Pointer) return Pointer;

   --  Return a pointer to the first operand of the node at P

   function String_Length

     (Program : Program_Data;

      P       : Pointer) return Program_Size;

   --  Return the length of the string argument of the node at P

   function String_Operand (P : Pointer) return Pointer;

   --  Return a pointer to the string argument of the node at P

   procedure Bitmap_Operand

     (Program : Program_Data;

      P       : Pointer;

      Op      : out Character_Class);

   --  Return a pointer to the string argument of the node at P

   function Get_Next_Offset

     (Program : Program_Data;

      IP      : Pointer) return Pointer;

   --  Get the offset field of a node. Used by Get_Next

   function Get_Next

     (Program : Program_Data;

      IP      : Pointer) return Pointer;

   --  Dig the next instruction pointer out of a node

   procedure Optimize (Self : in out Pattern_Matcher);

   --  Optimize a Pattern_Matcher by noting certain special cases

   function Read_Natural

     (Program : Program_Data;

      IP      : Pointer) return Natural;

   --  Return the 2-byte natural coded at position IP

   --  All of the subprograms above are tiny and should be inlined

   pragma Inline ("=");

   pragma Inline (Is_Alnum);

   pragma Inline (Is_White_Space);

   pragma Inline (Get_Next);

   pragma Inline (Get_Next_Offset);

   pragma Inline (Operand);

   pragma Inline (Read_Natural);

   pragma Inline (String_Length);

   pragma Inline (String_Operand);

   type Expression_Flags is record

      Has_Width,            -- Known never to match null string

      Simple,               -- Simple enough to be STAR/PLUS operand

      SP_Start  : Boolean;  -- Starts with * or +

   end record;

   Worst_Expression : constant Expression_Flags := (others => False);

   --  Worst case

   ---------

   -- "=" --

   ---------

   function "=" (Left : Character; Right : Opcode) return Boolean is

   begin

      return Character'Pos (Left) = Opcode'Pos (Right);

   end "=";

   --------------------

   -- Bitmap_Operand --

   --------------------

   procedure Bitmap_Operand

     (Program : Program_Data;

      P       : Pointer;

      Op      : out Character_Class)

   is

      function Convert is new Ada.Unchecked_Conversion

        (Program_Data, Character_Class);

   begin

      Op (0 .. 31) := Convert (Program (P + 3 .. P + 34));

   end Bitmap_Operand;

   -------------

   -- Compile --

   -------------

   procedure Compile

     (Matcher         : out Pattern_Matcher;

      Expression      : String;

      Final_Code_Size : out Program_Size;

      Flags           : Regexp_Flags := No_Flags)

   is

      --  We can't allocate space until we know how big the compiled form

      --  will be, but we can't compile it (and thus know how big it is)

      --  until we've got a place to put the code. So we cheat: we compile

      --  it twice, once with code generation turned off and size counting

      --  turned on, and once "for real".

      --  This also means that we don't allocate space until we are sure

      --  that the thing really will compile successfully, and we never

      --  have to move the code and thus invalidate pointers into it.

      --  Beware that the optimization-preparation code in here knows

      --  about some of the structure of the compiled regexp.

      PM        : Pattern_Matcher renames Matcher;

      Program   : Program_Data renames PM.Program;

      Emit_Code : constant Boolean := PM.Size > 0;

      Emit_Ptr  : Pointer := Program_First;

      Parse_Pos : Natural := Expression'First; -- Input-scan pointer

      Parse_End : constant Natural := Expression'Last;

      ----------------------------

      -- Subprograms for Create --

      ----------------------------

      procedure Emit (B : Character);

      --  Output the Character B to the Program. If code-generation is

      --  disabled, simply increments the program counter.

      function  Emit_Node (Op : Opcode) return Pointer;

      --  If code-generation is enabled, Emit_Node outputs the

      --  opcode Op and reserves space for a pointer to the next node.

      --  Return value is the location of new opcode, i.e. old Emit_Ptr.

      procedure Emit_Natural (IP : Pointer; N : Natural);

      --  Split N on two characters at position IP

      procedure Emit_Class (Bitmap : Character_Class);

      --  Emits a character class

      procedure Case_Emit (C : Character);

      --  Emit C, after converting is to lower-case if the regular

      --  expression is case insensitive.

      procedure Parse

        (Parenthesized : Boolean;

         Flags         : out Expression_Flags;

         IP            : out Pointer);

      --  Parse regular expression, i.e. main body or parenthesized thing

      --  Caller must absorb opening parenthesis.

      procedure Parse_Branch

        (Flags         : out Expression_Flags;

         First         : Boolean;

         IP            : out Pointer);

      --  Implements the concatenation operator and handles '|'

      --  First should be true if this is the first item of the alternative.

      procedure Parse_Piece

        (Expr_Flags : out Expression_Flags;

         IP         : out Pointer);

      --  Parse something followed by possible [*+?]

      procedure Parse_Atom

        (Expr_Flags : out Expression_Flags;

         IP         : out Pointer);

      --  Parse_Atom is the lowest level parse procedure.

      --  Optimization:  gobbles an entire sequence of ordinary characters

      --  so that it can turn them into a single node, which is smaller to

      --  store and faster to run. Backslashed characters are exceptions,

      --  each becoming a separate node; the code is simpler that way and

      --  it's not worth fixing.

      procedure Insert_Operator

        (Op       : Opcode;

         Operand  : Pointer;

         Greedy   : Boolean := True);

      --  Insert_Operator inserts an operator in front of an

      --  already-emitted operand and relocates the operand.

      --  This applies to PLUS and STAR.

      --  If Minmod is True, then the operator is non-greedy.

      procedure Insert_Curly_Operator

        (Op      : Opcode;

         Min     : Natural;

         Max     : Natural;

         Operand : Pointer;

         Greedy  : Boolean := True);

      --  Insert an operator for CURLY ({Min}, {Min,} or {Min,Max}).

      --  If Minmod is True, then the operator is non-greedy.

      procedure Link_Tail (P, Val : Pointer);

      --  Link_Tail sets the next-pointer at the end of a node chain

      procedure Link_Operand_Tail (P, Val : Pointer);

      --  Link_Tail on operand of first argument; noop if operand-less

      function  Next_Instruction (P : Pointer) return Pointer;

      --  Dig the "next" pointer out of a node

      procedure Fail (M : String);

      pragma No_Return (Fail);

      --  Fail with a diagnostic message, if possible

      function Is_Curly_Operator (IP : Natural) return Boolean;

      --  Return True if IP is looking at a '{' that is the beginning

      --  of a curly operator, i.e. it matches {\d+,?\d*}

      function Is_Mult (IP : Natural) return Boolean;

      --  Return True if C is a regexp multiplier: '+', '*' or '?'

      procedure Get_Curly_Arguments

        (IP     : Natural;

         Min    : out Natural;

         Max    : out Natural;

         Greedy : out Boolean);

      --  Parse the argument list for a curly operator.

      --  It is assumed that IP is indeed pointing at a valid operator.

      --  So what is IP and how come IP is not referenced in the body ???

      procedure Parse_Character_Class (IP : out Pointer);

      --  Parse a character class.

      --  The calling subprogram should consume the opening '[' before.

      procedure Parse_Literal

        (Expr_Flags : out Expression_Flags;

         IP         : out Pointer);

      --  Parse_Literal encodes a string of characters to be matched exactly

      function Parse_Posix_Character_Class return Std_Class;

      --  Parse a posix character class, like [:alpha:] or [:^alpha:].

      --  The caller is supposed to absorb the opening [.

      pragma Inline (Is_Mult);

      pragma Inline (Emit_Natural);

      pragma Inline (Parse_Character_Class); --  since used only once

      ---------------

      -- Case_Emit --

      ---------------

      procedure Case_Emit (C : Character) is

      begin

         if (Flags and Case_Insensitive) /= 0 then

            Emit (To_Lower (C));

         else

            --  Dump current character

            Emit (C);

         end if;

      end Case_Emit;

      ----------

      -- Emit --

      ----------

      procedure Emit (B : Character) is

      begin

         if Emit_Code then

            Program (Emit_Ptr) := B;

         end if;

         Emit_Ptr := Emit_Ptr + 1;

      end Emit;

      ----------------

      -- Emit_Class --

      ----------------

      procedure Emit_Class (Bitmap : Character_Class) is

         subtype Program31 is Program_Data (0 .. 31);

         function Convert is new Ada.Unchecked_Conversion

           (Character_Class, Program31);

      begin

         if Emit_Code then

            Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap);

         end if;

         Emit_Ptr := Emit_Ptr + 32;

      end Emit_Class;

      ------------------

      -- Emit_Natural --

      ------------------

      procedure Emit_Natural (IP : Pointer; N : Natural) is

      begin

         if Emit_Code then

            Program (IP + 1) := Character'Val (N / 256);

            Program (IP) := Character'Val (N mod 256);

         end if;

      end Emit_Natural;

      ---------------

      -- Emit_Node --

      ---------------

      function Emit_Node (Op : Opcode) return Pointer is

         Result : constant Pointer := Emit_Ptr;

      begin

         if Emit_Code then

            Program (Emit_Ptr) := Character'Val (Opcode'Pos (Op));

            Program (Emit_Ptr + 1) := ASCII.NUL;

            Program (Emit_Ptr + 2) := ASCII.NUL;

         end if;

         Emit_Ptr := Emit_Ptr + 3;

         return Result;

      end Emit_Node;

      ----------

      -- Fail --

      ----------

      procedure Fail (M : String) is

      begin

         raise Expression_Error with M;

      end Fail;

      -------------------------

      -- Get_Curly_Arguments --

      -------------------------

      procedure Get_Curly_Arguments

        (IP     : Natural;

         Min    : out Natural;

         Max    : out Natural;

         Greedy : out Boolean)

      is

         pragma Unreferenced (IP);

         Save_Pos : Natural := Parse_Pos + 1;

      begin

         Min := 0;

         Max := Max_Curly_Repeat;

         while Expression (Parse_Pos) /= '}'

           and then Expression (Parse_Pos) /= ','

         loop

            Parse_Pos := Parse_Pos + 1;

         end loop;

         Min := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1));

         if Expression (Parse_Pos) = ',' then

            Save_Pos := Parse_Pos + 1;

            while Expression (Parse_Pos) /= '}' loop

               Parse_Pos := Parse_Pos + 1;

            end loop;

            if Save_Pos /= Parse_Pos then

               Max := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1));

            end if;

         else

            Max := Min;

         end if;

         if Parse_Pos < Expression'Last

           and then Expression (Parse_Pos + 1) = '?'

         then

            Greedy := False;

            Parse_Pos := Parse_Pos + 1;

         else

            Greedy := True;

         end if;

      end Get_Curly_Arguments;

      ---------------------------

      -- Insert_Curly_Operator --

      ---------------------------

      procedure Insert_Curly_Operator

        (Op      : Opcode;

         Min     : Natural;

         Max     : Natural;

         Operand : Pointer;

         Greedy  : Boolean := True)

      is

         Dest   : constant Pointer := Emit_Ptr;

         Old    : Pointer;

         Size   : Pointer := 7;

      begin

         --  If the operand is not greedy, insert an extra operand before it

         if not Greedy then

            Size := Size + 3;

         end if;

         --  Move the operand in the byte-compilation, so that we can insert

         --  the operator before it.

         if Emit_Code then

            Program (Operand + Size .. Emit_Ptr + Size) :=

              Program (Operand .. Emit_Ptr);

         end if;

         --  Insert the operator at the position previously occupied by the

         --  operand.

         Emit_Ptr := Operand;

         if not Greedy then

            Old := Emit_Node (MINMOD);

            Link_Tail (Old, Old + 3);

         end if;

         Old := Emit_Node (Op);

         Emit_Natural (Old + 3, Min);

         Emit_Natural (Old + 5, Max);

         Emit_Ptr := Dest + Size;

      end Insert_Curly_Operator;

      ---------------------

      -- Insert_Operator --

      ---------------------

      procedure Insert_Operator

        (Op      : Opcode;

         Operand : Pointer;

         Greedy  : Boolean := True)

      is

         Dest : constant Pointer := Emit_Ptr;

         Old  : Pointer;

         Size : Pointer := 3;

         Discard : Pointer;

         pragma Warnings (Off, Discard);

      begin

         --  If not greedy, we have to emit another opcode first

         if not Greedy then

            Size := Size + 3;

         end if;

         --  Move the operand in the byte-compilation, so that we can insert

         --  the operator before it.

         if Emit_Code then

            Program (Operand + Size .. Emit_Ptr + Size) :=

              Program (Operand .. Emit_Ptr);

         end if;

         --  Insert the operator at the position previously occupied by the

         --  operand.

         Emit_Ptr := Operand;

         if not Greedy then

            Old := Emit_Node (MINMOD);

            Link_Tail (Old, Old + 3);

         end if;

         Discard := Emit_Node (Op);

         Emit_Ptr := Dest + Size;

      end Insert_Operator;

      -----------------------

      -- Is_Curly_Operator --

      -----------------------

      function Is_Curly_Operator (IP : Natural) return Boolean is

         Scan : Natural := IP;

      begin

         if Expression (Scan) /= '{'

           or else Scan + 2 > Expression'Last

           or else not Is_Digit (Expression (Scan + 1))

         then

            return False;

         end if;

         Scan := Scan + 1;

         --  The first digit

         loop

            Scan := Scan + 1;

            if Scan > Expression'Last then

               return False;

            end if;

            exit when not Is_Digit (Expression (Scan));

         end loop;

         if Expression (Scan) = ',' then

            loop

               Scan := Scan + 1;

               if Scan > Expression'Last then

                  return False;

               end if;

               exit when not Is_Digit (Expression (Scan));

            end loop;

         end if;

         return Expression (Scan) = '}';

      end Is_Curly_Operator;

      -------------

      -- Is_Mult --

      -------------

      function Is_Mult (IP : Natural) return Boolean is

         C : constant Character := Expression (IP);

      begin

         return     C = '*'

           or else  C = '+'

           or else  C = '?'

           or else (C = '{' and then Is_Curly_Operator (IP));

      end Is_Mult;

      -----------------------

      -- Link_Operand_Tail --

      -----------------------

      procedure Link_Operand_Tail (P, Val : Pointer) is

      begin

         if Emit_Code and then Program (P) = BRANCH then

            Link_Tail (Operand (P), Val);

         end if;

      end Link_Operand_Tail;

      ---------------

      -- Link_Tail --

      ---------------

      procedure Link_Tail (P, Val : Pointer) is