URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [fname.adb] - Rev 718
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- F N A M E -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2009, 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 3, 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. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Alloc; with Hostparm; use Hostparm; with Table; with Types; use Types; package body Fname is ----------------------------- -- Dummy Table Definitions -- ----------------------------- -- The following table was used in old versions of the compiler. We retain -- the declarations here for compatibility with old tree files. The new -- version of the compiler does not use this table, and will write out a -- dummy empty table for Tree_Write. type SFN_Entry is record U : Unit_Name_Type; F : File_Name_Type; end record; package SFN_Table is new Table.Table ( Table_Component_Type => SFN_Entry, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => Alloc.SFN_Table_Initial, Table_Increment => Alloc.SFN_Table_Increment, Table_Name => "Fname_Dummy_Table"); --------------------------- -- Is_Internal_File_Name -- --------------------------- function Is_Internal_File_Name (Fname : File_Name_Type; Renamings_Included : Boolean := True) return Boolean is begin if Is_Predefined_File_Name (Fname, Renamings_Included) then return True; -- Once Is_Predefined_File_Name has been called and returns False, -- Name_Buffer contains Fname and Name_Len is set to 8. elsif Name_Buffer (1 .. 2) = "g-" or else Name_Buffer (1 .. 8) = "gnat " then return True; elsif OpenVMS and then (Name_Buffer (1 .. 4) = "dec-" or else Name_Buffer (1 .. 8) = "dec ") then return True; else return False; end if; end Is_Internal_File_Name; ----------------------------- -- Is_Predefined_File_Name -- ----------------------------- -- This should really be a test of unit name, given the possibility of -- pragma Source_File_Name setting arbitrary file names for any files??? -- Once Is_Predefined_File_Name has been called and returns False, -- Name_Buffer contains Fname and Name_Len is set to 8. This is used -- only by Is_Internal_File_Name, and is not part of the official -- external interface of this function. function Is_Predefined_File_Name (Fname : File_Name_Type; Renamings_Included : Boolean := True) return Boolean is begin Get_Name_String (Fname); return Is_Predefined_File_Name (Renamings_Included); end Is_Predefined_File_Name; function Is_Predefined_File_Name (Renamings_Included : Boolean := True) return Boolean is subtype Str8 is String (1 .. 8); Predef_Names : constant array (1 .. 11) of Str8 := ("ada ", -- Ada "interfac", -- Interfaces "system ", -- System -- Remaining entries are only considered if Renamings_Included true "calendar", -- Calendar "machcode", -- Machine_Code "unchconv", -- Unchecked_Conversion "unchdeal", -- Unchecked_Deallocation "directio", -- Direct_IO "ioexcept", -- IO_Exceptions "sequenio", -- Sequential_IO "text_io "); -- Text_IO Num_Entries : constant Natural := 3 + 8 * Boolean'Pos (Renamings_Included); begin -- Remove extension (if present) if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then Name_Len := Name_Len - 4; end if; -- Definitely false if longer than 12 characters (8.3) if Name_Len > 8 then return False; -- Definitely predefined if prefix is a- i- or s- followed by letter elsif Name_Len >= 3 and then Name_Buffer (2) = '-' and then (Name_Buffer (1) = 'a' or else Name_Buffer (1) = 'i' or else Name_Buffer (1) = 's') and then (Name_Buffer (3) in 'a' .. 'z' or else Name_Buffer (3) in 'A' .. 'Z') then return True; end if; -- Otherwise check against special list, first padding to 8 characters while Name_Len < 8 loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ' '; end loop; for J in 1 .. Num_Entries loop if Name_Buffer (1 .. 8) = Predef_Names (J) then return True; end if; end loop; -- Note: when we return False here, the Name_Buffer contains the -- padded file name. This is not defined for clients of the package, -- but is used by Is_Internal_File_Name. return False; end Is_Predefined_File_Name; --------------- -- Tree_Read -- --------------- procedure Tree_Read is begin SFN_Table.Tree_Read; end Tree_Read; ---------------- -- Tree_Write -- ---------------- procedure Tree_Write is begin SFN_Table.Tree_Write; end Tree_Write; end Fname;
Go to most recent revision | Compare with Previous | Blame | View Log