Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / snames.adb < prev next >

Wrap

Text File | 1996-09-28 | 19KB | 670 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S N A M E S -- -- -- -- B o d y -- -- -- -- $Revision: 1.112 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- The GNAT library is free software; you can redistribute it and/or modify -- -- it under terms of the GNU Library General Public License as published by -- -- the Free Software Foundation; either version 2, or (at your option) any -- -- later version. The GNAT library is distributed in the hope that it will -- -- be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -- -- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- Library General Public License for more details. You should have -- -- received a copy of the GNU Library General Public License along with -- -- the GNAT library; see the file COPYING.LIB. If not, write to the Free -- -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; package body Snames is -- Table of names to be set by Initialize. Each name is terminated by a -- single #, and the end of the list is marked by a null entry, i.e. by -- two # marks in succession. Note that the table does not include the -- entries for a-z, since these are initialized by Namet itself. Preset_Names : constant String := "_abort_signal#" & "_assign#" & "_chain#" & "_clean#" & "_controller#" & "_entry_bodies#" & "_expunge#" & "_final_list#" & "_idepth#" & "_init#" & "_local_final_list#" & "_master#" & "_object#" & "_parent#" & "_priority#" & "_service#" & "_size#" & "_tag#" & "_tags#" & "_task#" & "_task_id#" & "_trace_sp#" & "initialize#" & "adjust#" & "finalize#" & "next#" & "prev#" & "_deep_adjust#" & "_equality#" & "_deep_finalize#" & "_deep_initialize#" & "_init_proc#" & "_input#" & "_output#" & "_read#" & "_rep_to_pos#" & "_write#" & "allocate#" & "deallocate#" & "decimal_io#" & "enumeration_io#" & "fixed_io#" & "float_io#" & "integer_io#" & "modular_io#" & "a_textio#" & "a_witeio#" & "const#" & "<error>#" & "go#" & "put#" & "put_line#" & "to#" & "finalization#" & "finalization_implementation#" & "interfaces#" & "standard#" & "system#" & "ast_receiver#" & "do_rpc#" & "do_apc#" & "exception_identity#" & "exceptions#" & "exception_occurrence#" & "get_local_partition_id#" & "null_id#" & "params#" & "params_stream_type#" & "partition_interface#" & "pid#" & "pointer#" & "result#" & "rpc#" & "rpc_receiver#" & "stream_element_offset#" & "streams#" & "Oabs#" & "Oand#" & "Omod#" & "Onot#" & "Oor#" & "Orem#" & "Oxor#" & "Oeq#" & "One#" & "Olt#" & "Ole#" & "Ogt#" & "Oge#" & "Oadd#" & "Osubtract#" & "Oconcat#" & "Omultiply#" & "Odivide#" & "Oexpon#" & "abort_defer#" & "ada_83#" & "ada_95#" & "all_calls_remote#" & "annotate#" & "assert#" & "asynchronous#" & "atomic#" & "atomic_components#" & "attach_handler#" & "controlled#" & "convention#" & "cpp_class#" & "cpp_constructor#" & "cpp_destructor#" & "cpp_virtual#" & "cpp_vtable#" & "debug#" & "discard_names#" & "elaborate#" & "elaborate_all#" & "elaborate_body#" & "error_monitoring#" & "export#" & "import#" & "inline#" & "inspection_point#" & "interface#" & "interface_name#" & "interrupt_handler#" & "interrupt_priority#" & "linker_options#" & "list#" & "locking_policy#" & "machine_attribute#" & "memory_size#" & "normalize_scalars#" & "optimize#" & "pack#" & "page#" & "preelaborate#" & "priority#" & "pure#" & "queuing_policy#" & "remote_call_interface#" & "remote_types#" & "restrictions#" & "reviewable#" & "shared#" & "shared_passive#" & "source_reference#" & "suppress#" & "system_name#" & "task_dispatching_policy#" & "unimplemented_unit#" & "unsuppress#" & "volatile#" & "volatile_components#" & "ada#" & "asm#" & "assembler#" & "cobol#" & "cpp#" & "fortran#" & "intrinsic#" & "stdcall#" & "attribute_name#" & "component#" & "entity#" & "entry_count#" & "external_name#" & "gcc#" & "gnat#" & "link_name#" & "off#" & "on#" & "space#" & "time#" & "vtable_ptr#" & "abort_signal#" & "access#" & "address#" & "address_size#" & "adjacent#" & "aft#" & "alignment#" & "bit_order#" & "body_version#" & "callable#" & "caller#" & "ceiling#" & "component_size#" & "compose#" & "constrained#" & "copy_sign#" & "count#" & "default_bit_order#" & "definite#" & "delta#" & "denorm#" & "digits#" & "emax#" & "enum_rep#" & "epsilon#" & "exponent#" & "external_tag#" & "first#" & "first_bit#" & "fixed_value#" & "floor#" & "fore#" & "fraction#" & "identity#" & "image#" & "img#" & "input#" & "integer_value#" & "large#" & "last#" & "last_bit#" & "leading_part#" & "length#" & "machine#" & "machine_emax#" & "machine_emin#" & "machine_mantissa#" & "machine_overflows#" & "machine_radix#" & "machine_rounds#" & "mantissa#" & "max#" & "max_interrupt_priority#" & "max_priority#" & "max_size_in_storage_elements#" & "maximum_alignment#" & "min#" & "model#" & "model_emin#" & "model_epsilon#" & "model_mantissa#" & "model_small#" & "modulus#" & "output#" & "partition_id#" & "passed_by_reference#" & "pos#" & "position#" & "pred#" & "range#" & "range_length#" & "read#" & "remainder#" & "round#" & "rounding#" & "safe_emax#" & "safe_first#" & "safe_large#" & "safe_last#" & "safe_small#" & "scale#" & "scaling#" & "signed_zeros#" & "size#" & "small#" & "storage_size#" & "storage_unit#" & "succ#" & "tag#" & "terminated#" & "tick#" & "truncation#" & "unbiased_rounding#" & "unchecked_access#" & "universal_literal_string#" & "unrestricted_access#" & "val#" & "valid#" & "value#" & "version#" & "wide_image#" & "wide_value#" & "wide_width#" & "width#" & "word_size#" & "write#" & "elab_body#" & "elab_spec#" & "storage_pool#" & "base#" & "class#" & "ceiling_locking#" & "fifo_queuing#" & "priority_queuing#" & "fifo_within_priorities#" & "access_check#" & "accessibility_check#" & "discriminant_check#" & "division_check#" & "elaboration_check#" & "index_check#" & "length_check#" & "overflow_check#" & "range_check#" & "storage_check#" & "tag_check#" & "all_checks#" & "abort#" & "abs#" & "abstract#" & "accept#" & "and#" & "all#" & "array#" & "at#" & "begin#" & "body#" & "case#" & "constant#" & "declare#" & "delay#" & "do#" & "else#" & "elsif#" & "end#" & "entry#" & "exception#" & "exit#" & "for#" & "function#" & "generic#" & "goto#" & "if#" & "in#" & "is#" & "limited#" & "loop#" & "mod#" & "new#" & "not#" & "null#" & "of#" & "or#" & "others#" & "out#" & "package#" & "pragma#" & "private#" & "procedure#" & "raise#" & "record#" & "rem#" & "renames#" & "return#" & "reverse#" & "select#" & "separate#" & "subtype#" & "task#" & "terminate#" & "then#" & "type#" & "use#" & "when#" & "while#" & "with#" & "xor#" & "divide#" & "rotate_left#" & "rotate_right#" & "shift_left#" & "shift_right#" & "shift_right_arithmetic#" & "unchecked_conversion#" & "unchecked_deallocation#" & "aliased#" & "protected#" & "until#" & "requeue#" & "tagged#" & "#"; --------------------- -- Generated Names -- --------------------- -- This section lists the various cases of generated names which are -- built from existing names by adding unique leading and/or trailing -- upper case letters. In some cases these names are built recursively, -- in particular names built from types may be built from types which -- themselves have generated names. In this list, xxx represents an -- existing name to which identifying letters are prepended or appended, -- and a trailing n represents a serial number in an external name that -- has some semantic significance (e.g. the n'th index type of an array). -- xxxA access type for formal xxx in entry param record (Exp_Ch9) -- xxxB tag table for tagged type xxx (Exp_Ch3) -- xxxB task body procedure for task xxx (Exp_Ch9) -- xxxD dispatch table for tagged type xxx (Exp_Ch3) -- xxxD discriminal for discriminant xxx (Sem_Ch3) -- xxxDn n'th discr check function for rec type xxx (Exp_Ch3) -- xxxE elaboration boolean flag for task xxx (Exp_Ch9) -- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3) -- xxxE parameters for accept body for entry xxx (Exp_Ch9) -- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3) -- xxxI initialization procedure for type xxx (Exp_Ch3) -- xxxJ tag table type index for tagged type xxx (Exp_Ch3) -- xxxM master Id value for access type xxx (Exp_Ch3) -- xxxP tag table pointer type for tagged type xxx (Exp_Ch3) -- xxxP parameter record type for entry xxx (Exp_Ch9) -- xxxPA access to parameter record type for entry xxx (Exp_Ch9) -- xxxPn pointer type for n'th primitive of tagged type xxx (Exp_Ch3) -- xxxR dispatch table pointer for tagged type xxx (Exp_Ch3) -- xxxT tag table type for tagged type xxx (Exp_Ch3) -- xxxT literal table for enumeration type xxx (Sem_Ch3) -- xxxV type for task value record for task xxx (Exp_Ch9) -- xxxX entry index constant (Exp_Ch9) -- xxxY dispatch table type for tagged type xxx (Exp_Ch3) -- xxxZ size variable for task xxx (Exp_Ch9) -- Implicit type names -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3) -- (list not yet complete ???) ---------------------- -- Get_Attribute_Id -- ---------------------- function Get_Attribute_Id (N : Name_Id) return Attribute_Id is begin return Attribute_Id'Val (N - First_Attribute_Name); end Get_Attribute_Id; ------------------ -- Get_Check_Id -- ------------------ function Get_Check_Id (N : Name_Id) return Check_Id is begin return Check_Id'Val (N - First_Check_Name); end Get_Check_Id; ----------------------- -- Get_Convention_Id -- ----------------------- function Get_Convention_Id (N : Name_Id) return Convention_Id is begin case N is when Name_Ada => return Convention_Ada; when Name_Asm => return Convention_Assembler; when Name_Assembler => return Convention_Assembler; when Name_C => return Convention_C; when Name_COBOL => return Convention_COBOL; when Name_CPP => return Convention_CPP; when Name_Fortran => return Convention_Fortran; when Name_Intrinsic => return Convention_Intrinsic; when Name_Stdcall => return Convention_Stdcall; when others => pragma Assert (False); null; end case; end Get_Convention_Id; --------------------------- -- Get_Locking_Policy_Id -- --------------------------- function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is begin return Locking_Policy_Id'Val (N - First_Locking_Policy_Name); end Get_Locking_Policy_Id; ------------------- -- Get_Pragma_Id -- ------------------- function Get_Pragma_Id (N : Name_Id) return Pragma_Id is begin if N = Name_Storage_Size then return Pragma_Storage_Size; elsif N = Name_Storage_Unit then return Pragma_Storage_Unit; else return Pragma_Id'Val (N - First_Pragma_Name); end if; end Get_Pragma_Id; --------------------------- -- Get_Queuing_Policy_Id -- --------------------------- function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is begin return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name); end Get_Queuing_Policy_Id; ------------------------------------ -- Get_Task_Dispatching_Policy_Id -- ------------------------------------ function Get_Task_Dispatching_Policy_Id (N : Name_Id) return Task_Dispatching_Policy_Id is begin return Task_Dispatching_Policy_Id'Val (N - First_Task_Dispatching_Policy_Name); end Get_Task_Dispatching_Policy_Id; ---------------- -- Initialize -- ---------------- procedure Initialize is P_Index : Natural; Discard_Name : Name_Id; begin P_Index := Preset_Names'First; loop Name_Len := 0; while Preset_Names (P_Index) /= '#' loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Preset_Names (P_Index); P_Index := P_Index + 1; end loop; -- We do the Name_Find call to enter the name into the table, but -- we don't need to do anything with the result, since we already -- initialized all the preset names to have the right value (we -- are depending on the order of the names and Preset_Names). Discard_Name := Name_Find; P_Index := P_Index + 1; exit when Preset_Names (P_Index) = '#'; end loop; -- Make sure that number of names in standard table is correct. If -- this check fails, run utility program XSNAMES to construct a new -- properly matching version of the body. pragma Assert (Discard_Name = Last_Predefined_Name); end Initialize; ----------------------- -- Is_Attribute_Name -- ----------------------- function Is_Attribute_Name (N : Name_Id) return Boolean is begin return N in First_Attribute_Name .. Last_Attribute_Name; end Is_Attribute_Name; ------------------------------ -- Is_Entity_Attribute_Name -- ------------------------------ function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is begin return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name; end Is_Entity_Attribute_Name; ---------------------------- -- Is_Type_Attribute_Name -- ---------------------------- function Is_Type_Attribute_Name (N : Name_Id) return Boolean is begin return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name; end Is_Type_Attribute_Name; ------------------- -- Is_Check_Name -- ------------------- function Is_Check_Name (N : Name_Id) return Boolean is begin return N in First_Check_Name .. Last_Check_Name; end Is_Check_Name; ------------------------ -- Is_Convention_Name -- ------------------------ function Is_Convention_Name (N : Name_Id) return Boolean is begin return N in First_Convention_Name .. Last_Convention_Name or else N = Name_C; end Is_Convention_Name; ---------------------------- -- Is_Locking_Policy_Name -- ---------------------------- function Is_Locking_Policy_Name (N : Name_Id) return Boolean is begin return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name; end Is_Locking_Policy_Name; ----------------------------- -- Is_Operator_Symbol_Name -- ----------------------------- function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is begin return N in First_Operator_Name .. Last_Operator_Name; end Is_Operator_Symbol_Name; -------------------- -- Is_Pragma_Name -- -------------------- function Is_Pragma_Name (N : Name_Id) return Boolean is begin return N in First_Pragma_Name .. Last_Pragma_Name or else N = Name_Storage_Size or else N = Name_Storage_Unit; end Is_Pragma_Name; ---------------------------- -- Is_Queuing_Policy_Name -- ---------------------------- function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is begin return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name; end Is_Queuing_Policy_Name; ------------------------------------- -- Is_Task_Dispatching_Policy_Name -- ------------------------------------- function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is begin return N in First_Task_Dispatching_Policy_Name .. Last_Task_Dispatching_Policy_Name; end Is_Task_Dispatching_Policy_Name; end Snames;