| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S T R I N G T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- |
| -- -- |
| -- 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, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, 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. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Alloc; |
| with Namet; use Namet; |
| with Output; use Output; |
| with Table; |
| |
| package body Stringt is |
| |
| -- The following table stores the sequence of character codes for the |
| -- stored string constants. The entries are referenced from the |
| -- separate Strings table. |
| |
| package String_Chars is new Table.Table ( |
| Table_Component_Type => Char_Code, |
| Table_Index_Type => Int, |
| Table_Low_Bound => 0, |
| Table_Initial => Alloc.String_Chars_Initial, |
| Table_Increment => Alloc.String_Chars_Increment, |
| Table_Name => "String_Chars"); |
| |
| -- The String_Id values reference entries in the Strings table, which |
| -- contains String_Entry records that record the length of each stored |
| -- string and its starting location in the String_Chars table. |
| |
| type String_Entry is record |
| String_Index : Int; |
| Length : Nat; |
| end record; |
| |
| package Strings is new Table.Table ( |
| Table_Component_Type => String_Entry, |
| Table_Index_Type => String_Id, |
| Table_Low_Bound => First_String_Id, |
| Table_Initial => Alloc.Strings_Initial, |
| Table_Increment => Alloc.Strings_Increment, |
| Table_Name => "Strings"); |
| |
| -- Note: it is possible that two entries in the Strings table can share |
| -- string data in the String_Chars table, and in particular this happens |
| -- when Start_String is called with a parameter that is the last string |
| -- currently allocated in the table. |
| |
| ------------------------------- |
| -- Add_String_To_Name_Buffer -- |
| ------------------------------- |
| |
| procedure Add_String_To_Name_Buffer (S : String_Id) is |
| Len : constant Natural := Natural (String_Length (S)); |
| |
| begin |
| for J in 1 .. Len loop |
| Name_Buffer (Name_Len + J) := |
| Get_Character (Get_String_Char (S, Int (J))); |
| end loop; |
| |
| Name_Len := Name_Len + Len; |
| end Add_String_To_Name_Buffer; |
| |
| ---------------- |
| -- End_String -- |
| ---------------- |
| |
| function End_String return String_Id is |
| begin |
| return Strings.Last; |
| end End_String; |
| |
| --------------------- |
| -- Get_String_Char -- |
| --------------------- |
| |
| function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is |
| begin |
| pragma Assert (Id in First_String_Id .. Strings.Last |
| and then Index in 1 .. Strings.Table (Id).Length); |
| |
| return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1); |
| end Get_String_Char; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize is |
| begin |
| String_Chars.Init; |
| Strings.Init; |
| end Initialize; |
| |
| ---------- |
| -- Lock -- |
| ---------- |
| |
| procedure Lock is |
| begin |
| String_Chars.Locked := True; |
| Strings.Locked := True; |
| String_Chars.Release; |
| Strings.Release; |
| end Lock; |
| |
| ------------------ |
| -- Start_String -- |
| ------------------ |
| |
| -- Version to start completely new string |
| |
| procedure Start_String is |
| begin |
| Strings.Increment_Last; |
| Strings.Table (Strings.Last).String_Index := String_Chars.Last + 1; |
| Strings.Table (Strings.Last).Length := 0; |
| end Start_String; |
| |
| -- Version to start from initially stored string |
| |
| procedure Start_String (S : String_Id) is |
| begin |
| Strings.Increment_Last; |
| |
| -- Case of initial string value is at the end of the string characters |
| -- table, so it does not need copying, instead it can be shared. |
| |
| if Strings.Table (S).String_Index + Strings.Table (S).Length = |
| String_Chars.Last + 1 |
| then |
| Strings.Table (Strings.Last).String_Index := |
| Strings.Table (S).String_Index; |
| |
| -- Case of initial string value must be copied to new string |
| |
| else |
| Strings.Table (Strings.Last).String_Index := |
| String_Chars.Last + 1; |
| |
| for J in 1 .. Strings.Table (S).Length loop |
| String_Chars.Increment_Last; |
| String_Chars.Table (String_Chars.Last) := |
| String_Chars.Table (Strings.Table (S).String_Index + (J - 1)); |
| end loop; |
| end if; |
| |
| -- In either case the result string length is copied from the argument |
| |
| Strings.Table (Strings.Last).Length := Strings.Table (S).Length; |
| end Start_String; |
| |
| ----------------------- |
| -- Store_String_Char -- |
| ----------------------- |
| |
| procedure Store_String_Char (C : Char_Code) is |
| begin |
| String_Chars.Increment_Last; |
| String_Chars.Table (String_Chars.Last) := C; |
| Strings.Table (Strings.Last).Length := |
| Strings.Table (Strings.Last).Length + 1; |
| end Store_String_Char; |
| |
| procedure Store_String_Char (C : Character) is |
| begin |
| Store_String_Char (Get_Char_Code (C)); |
| end Store_String_Char; |
| |
| ------------------------ |
| -- Store_String_Chars -- |
| ------------------------ |
| |
| procedure Store_String_Chars (S : String) is |
| begin |
| for J in S'First .. S'Last loop |
| Store_String_Char (Get_Char_Code (S (J))); |
| end loop; |
| end Store_String_Chars; |
| |
| procedure Store_String_Chars (S : String_Id) is |
| begin |
| for J in 1 .. String_Length (S) loop |
| Store_String_Char (Get_String_Char (S, J)); |
| end loop; |
| end Store_String_Chars; |
| |
| ---------------------- |
| -- Store_String_Int -- |
| ---------------------- |
| |
| procedure Store_String_Int (N : Int) is |
| begin |
| if N < 0 then |
| Store_String_Char ('-'); |
| Store_String_Int (-N); |
| |
| else |
| if N > 9 then |
| Store_String_Int (N / 10); |
| end if; |
| |
| Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10)); |
| end if; |
| end Store_String_Int; |
| |
| -------------------------- |
| -- String_Chars_Address -- |
| -------------------------- |
| |
| function String_Chars_Address return System.Address is |
| begin |
| return String_Chars.Table (0)'Address; |
| end String_Chars_Address; |
| |
| ------------------ |
| -- String_Equal -- |
| ------------------ |
| |
| function String_Equal (L, R : String_Id) return Boolean is |
| Len : constant Nat := Strings.Table (L).Length; |
| |
| begin |
| if Len /= Strings.Table (R).Length then |
| return False; |
| else |
| for J in 1 .. Len loop |
| if Get_String_Char (L, J) /= Get_String_Char (R, J) then |
| return False; |
| end if; |
| end loop; |
| |
| return True; |
| end if; |
| end String_Equal; |
| |
| ----------------------------- |
| -- String_From_Name_Buffer -- |
| ----------------------------- |
| |
| function String_From_Name_Buffer return String_Id is |
| begin |
| Start_String; |
| |
| for J in 1 .. Name_Len loop |
| Store_String_Char (Get_Char_Code (Name_Buffer (J))); |
| end loop; |
| |
| return End_String; |
| end String_From_Name_Buffer; |
| |
| ------------------- |
| -- String_Length -- |
| ------------------- |
| |
| function String_Length (Id : String_Id) return Nat is |
| begin |
| return Strings.Table (Id).Length; |
| end String_Length; |
| |
| --------------------------- |
| -- String_To_Name_Buffer -- |
| --------------------------- |
| |
| procedure String_To_Name_Buffer (S : String_Id) is |
| begin |
| Name_Len := Natural (String_Length (S)); |
| |
| for J in 1 .. Name_Len loop |
| Name_Buffer (J) := |
| Get_Character (Get_String_Char (S, Int (J))); |
| end loop; |
| end String_To_Name_Buffer; |
| |
| --------------------- |
| -- Strings_Address -- |
| --------------------- |
| |
| function Strings_Address return System.Address is |
| begin |
| return Strings.Table (First_String_Id)'Address; |
| end Strings_Address; |
| |
| --------------- |
| -- Tree_Read -- |
| --------------- |
| |
| procedure Tree_Read is |
| begin |
| String_Chars.Tree_Read; |
| Strings.Tree_Read; |
| end Tree_Read; |
| |
| ---------------- |
| -- Tree_Write -- |
| ---------------- |
| |
| procedure Tree_Write is |
| begin |
| String_Chars.Tree_Write; |
| Strings.Tree_Write; |
| end Tree_Write; |
| |
| ------------ |
| -- Unlock -- |
| ------------ |
| |
| procedure Unlock is |
| begin |
| String_Chars.Locked := False; |
| Strings.Locked := False; |
| end Unlock; |
| |
| ------------------------- |
| -- Unstore_String_Char -- |
| ------------------------- |
| |
| procedure Unstore_String_Char is |
| begin |
| String_Chars.Decrement_Last; |
| Strings.Table (Strings.Last).Length := |
| Strings.Table (Strings.Last).Length - 1; |
| end Unstore_String_Char; |
| |
| --------------------- |
| -- Write_Char_Code -- |
| --------------------- |
| |
| procedure Write_Char_Code (Code : Char_Code) is |
| |
| procedure Write_Hex_Byte (J : Natural); |
| -- Write single hex digit |
| |
| -------------------- |
| -- Write_Hex_Byte -- |
| -------------------- |
| |
| procedure Write_Hex_Byte (J : Natural) is |
| Hexd : constant String := "0123456789abcdef"; |
| |
| begin |
| Write_Char (Hexd (J / 16 + 1)); |
| Write_Char (Hexd (J mod 16 + 1)); |
| end Write_Hex_Byte; |
| |
| -- Start of processing for Write_Char_Code |
| |
| begin |
| if Code in 16#20# .. 16#7E# then |
| Write_Char (Character'Val (Code)); |
| |
| else |
| Write_Char ('['); |
| Write_Char ('"'); |
| |
| if Code > 16#FF# then |
| Write_Hex_Byte (Natural (Code / 256)); |
| end if; |
| |
| Write_Hex_Byte (Natural (Code mod 256)); |
| Write_Char ('"'); |
| Write_Char (']'); |
| end if; |
| end Write_Char_Code; |
| |
| ------------------------------ |
| -- Write_String_Table_Entry -- |
| ------------------------------ |
| |
| procedure Write_String_Table_Entry (Id : String_Id) is |
| C : Char_Code; |
| |
| begin |
| if Id = No_String then |
| Write_Str ("no string"); |
| |
| else |
| Write_Char ('"'); |
| |
| for J in 1 .. String_Length (Id) loop |
| C := Get_String_Char (Id, J); |
| |
| if Character'Val (C) = '"' then |
| Write_Str (""""""); |
| |
| else |
| Write_Char_Code (C); |
| end if; |
| end loop; |
| |
| Write_Char ('"'); |
| end if; |
| end Write_String_Table_Entry; |
| |
| end Stringt; |
