-- VHDL libraries handling. -- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 2 of the License, or -- (at your option) any later version. -- -- This program 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 General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . with System; with Interfaces.C_Streams; with GNAT.OS_Lib; with Logging; use Logging; with Tables; with Errorout; use Errorout; with Options; use Options; with Name_Table; use Name_Table; with Str_Table; with Files_Map; with Flags; with Std_Names; with Vhdl.Tokens; with Vhdl.Std_Package; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Scanner; with Vhdl.Utils; use Vhdl.Utils; package body Libraries is -- Chain of known libraries. This is also the top node of all iir node. Libraries_Chain : Iir_Library_Declaration := Null_Iir; Libraries_Chain_Last : Iir_Library_Declaration := Null_Iir; -- Last design_file used. Kept to speed-up operations. Last_Design_File : Iir_Design_File := Null_Iir; -- Table of library paths. package Paths is new Tables (Table_Index_Type => Integer, Table_Component_Type => Name_Id, Table_Low_Bound => 1, Table_Initial => 4); -- Report an error message. procedure Error_Lib_Msg (Msg : String) is begin Report_Msg (Msgid_Error, Library, No_Source_Coord, Msg); end Error_Lib_Msg; procedure Create_Virtual_Locations is use Files_Map; Library_Source_File : Source_File_Entry; Command_Source_File : Source_File_Entry; begin Library_Source_File := Create_Virtual_Source_File (Get_Identifier ("*libraries*")); Command_Source_File := Create_Virtual_Source_File (Get_Identifier ("*command line*")); Command_Line_Location := File_To_Location (Command_Source_File); Library_Location := File_To_Location (Library_Source_File); end Create_Virtual_Locations; -- Initialize paths table. -- Set the local path. procedure Initialize is begin -- Always look in current directory first. Paths.Init; Name_Nil := Get_Identifier (""); Paths.Append (Name_Nil); Local_Directory := Name_Nil; Work_Directory := Name_Nil; Libraries_Chain := Null_Iir; Std_Library := Null_Iir; Work_Library_Name := Std_Names.Name_Work; Create_Virtual_Locations; end Initialize; procedure Finalize is begin Paths.Free; end Finalize; function Path_To_Id (Path : String) return Name_Id is begin if Path (Path'Last) /= GNAT.OS_Lib.Directory_Separator then return Get_Identifier (Path & GNAT.OS_Lib.Directory_Separator); else return Get_Identifier (Path); end if; end Path_To_Id; procedure Add_Library_Path (Path : String) is begin if Path'Length = 0 then return; end if; Paths.Append (Path_To_Id (Path)); end Add_Library_Path; function Get_Nbr_Paths return Natural is begin return Paths.Last; end Get_Nbr_Paths; function Get_Path (N : Natural) return Name_Id is begin if N not in Paths.First .. Paths.Last then raise Constraint_Error; end if; return Paths.Table (N); end Get_Path; -- Transform a library identifier into a file name. -- Very simple mechanism: just add '-objVV.cf' extension, where VV -- is the version. function Library_To_File_Name (Library: Iir_Library_Declaration) return String is use Flags; begin case Vhdl_Std is when Vhdl_87 => return Image_Identifier (Library) & "-obj87.cf"; when Vhdl_93 | Vhdl_00 | Vhdl_02 => return Image_Identifier (Library) & "-obj93.cf"; when Vhdl_08 => return Image_Identifier (Library) & "-obj08.cf"; when Vhdl_19 => return Image_Identifier (Library) & "-obj19.cf"; end case; end Library_To_File_Name; -- Search LIBRARY in the library path. procedure Search_Library_In_Path (Library : Iir) is use Flags; File_Name : constant String := Library_To_File_Name (Library); Library_Id : constant Name_Id := Get_Identifier (Library); Id_Len : constant Natural := Get_Name_Length (Library_Id); begin for I in Paths.First .. Paths.Last loop -- Try PATH/LIBxxx.cf declare Path : constant String := Image (Paths.Table (I)) & File_Name & ASCII.NUL; begin if GNAT.OS_Lib.Is_Regular_File (Path'Address) then Set_Library_Directory (Library, Paths.Table (I)); exit; end if; end; -- Try PATH/LIB/vNN/LIBxxx.cf declare Pfx : constant String := Image (Paths.Table (I)); Pfx_Len : constant Natural := Pfx'Length; L : Natural; Path : String (1 .. Pfx_Len + Id_Len + 5 + File_Name'Length + 1); begin L := Pfx_Len; Path (1 .. L) := Pfx; Path (L + 1 .. L + Id_Len) := Image (Library_Id); L := L + Id_Len; Path (L + 1) := GNAT.OS_Lib.Directory_Separator; case Vhdl_Std is when Vhdl_87 => Path (L + 2 .. L + 4) := "v87"; when Vhdl_93 | Vhdl_00 | Vhdl_02 => Path (L + 2 .. L + 4) := "v93"; when Vhdl_08 => Path (L + 2 .. L + 4) := "v08"; when Vhdl_19 => Path (L + 2 .. L + 4) := "v19"; end case; L := L + 5; Path (L) := GNAT.OS_Lib.Directory_Separator; Path (L + 1 .. L + File_Name'Length) := File_Name; Path (L + File_Name'Length + 1) := Character'Val (0); if GNAT.OS_Lib.Is_Regular_File (Path'Address) then -- For Get_Identifier: keep only the path part (including the -- trailing path separator). Set_Library_Directory (Library, Get_Identifier (Path (1 .. L))); exit; end if; end; end loop; end Search_Library_In_Path; -- Set PATH as the path of the work library. procedure Set_Work_Library_Path (Path : String) is begin Work_Directory := Path_To_Id (Path); if not GNAT.OS_Lib.Is_Directory (Get_Address (Work_Directory)) and then Is_Warning_Enabled (Warnid_Library) then -- This is a warning, since 'clean' action should not fail in -- this cases. Warning_Msg_Option (Warnid_Library, "directory '" & Path & "' set by --workdir= does not exist"); -- raise Option_Error; end if; end Set_Work_Library_Path; -- Every design unit is put in this hash table to be quickly found by -- its (primary) identifier. Unit_Hash_Length : constant Name_Id := 127; subtype Hash_Id is Name_Id range 0 .. Unit_Hash_Length - 1; Unit_Hash_Table : array (Hash_Id) of Iir := (others => Null_Iir); -- Get the hash value for DESIGN_UNIT. -- Architectures use the entity name. function Get_Hash_Id_For_Unit (Design_Unit : Iir_Design_Unit) return Hash_Id is Lib_Unit : Iir; Id : Name_Id; begin if Get_Kind (Design_Unit) = Iir_Kind_Foreign_Module then Id := Get_Identifier (Design_Unit); else Lib_Unit := Get_Library_Unit (Design_Unit); case Iir_Kinds_Library_Unit (Get_Kind (Lib_Unit)) is when Iir_Kinds_Primary_Unit | Iir_Kind_Package_Body | Iir_Kind_Foreign_Module => Id := Get_Identifier (Lib_Unit); when Iir_Kind_Architecture_Body => -- Architectures are put with the entity identifier. Id := Get_Entity_Identifier_Of_Architecture (Lib_Unit); end case; end if; return Id mod Unit_Hash_Length; end Get_Hash_Id_For_Unit; -- Put DESIGN_UNIT into the unit hash table. procedure Add_Unit_Hash (Design_Unit : Iir) is Id : Hash_Id; begin Id := Get_Hash_Id_For_Unit (Design_Unit); Set_Hash_Chain (Design_Unit, Unit_Hash_Table (Id)); Unit_Hash_Table (Id) := Design_Unit; end Add_Unit_Hash; -- Remove DESIGN_UNIT from the unit hash table. procedure Remove_Unit_Hash (Design_Unit : Iir) is Id : Hash_Id; Unit, Prev, Next : Iir_Design_Unit; begin Id := Get_Hash_Id_For_Unit (Design_Unit); Unit := Unit_Hash_Table (Id); Prev := Null_Iir; while Unit /= Null_Iir loop Next := Get_Hash_Chain (Unit); if Unit = Design_Unit then if Prev = Null_Iir then Unit_Hash_Table (Id) := Next; else Set_Hash_Chain (Prev, Next); end if; return; end if; Prev := Unit; Unit := Next; end loop; -- Not found. raise Internal_Error; end Remove_Unit_Hash; procedure Purge_Design_File (Design_File : Iir_Design_File) is Prev, File, Next : Iir_Design_File; Unit : Iir_Design_Unit; File_Name : constant Name_Id := Get_Design_File_Filename (Design_File); Dir_Name : constant Name_Id := Get_Design_File_Directory (Design_File); begi
##############################################################################
# Build global options
# NOTE: Can be overridden externally.
#

# Compiler options here.
ifeq ($(USE_OPT),)
  USE_OPT = -O2 -ggdb -fomit-frame-pointer -falign-functions=16
endif

# C specific options here (added to USE_OPT).
ifeq ($(USE_COPT),)
  USE_COPT = 
endif

# C++ specific options here (added to USE_OPT).
ifeq ($(USE_CPPOPT),)
  USE_CPPOPT = -fno-rtti
endif

# Enable this if you want the linker to remove unused code and data
ifeq ($(USE_LINK_GC),)
  USE_LINK_GC = yes
endif

# Enable this if you want link time optimizations (LTO)
ifeq ($(USE_LTO),)
  USE_LTO = yes
endif

# If enabled, this option allows to compile the application in THUMB mode.
ifeq ($(USE_THUMB),)
  USE_THUMB = yes
endif

# Enable this if you want to see the full log while compiling.
ifeq ($(USE_VERBOSE_COMPILE),)
  USE_VERBOSE_COMPILE = no
endif

#
# Build global options
##############################################################################

##############################################################################
# Architecture or project specific options
#

# Stack size to be allocated to the Cortex-M process stack. This stack is
# the stack used by the main() thread.
ifeq ($(USE_PROCESS_STACKSIZE),)
  USE_PROCESS_STACKSIZE = 0x400
endif

# Stack size to the allocated to the Cortex-M main/exceptions stack. This
# stack is used for processing interrupts and exceptions.
ifeq ($(USE_EXCEPTIONS_STACKSIZE),)
  USE_EXCEPTIONS_STACKSIZE = 0x400
endif

# Enables the use of FPU on Cortex-M4 (no, softfp, hard).
ifeq ($(USE_FPU),)
  USE_FPU = no
endif

#
# Architecture or project specific options
##############################################################################

##############################################################################
# Project, sources and paths
#

# Define project name here
PROJECT = ch

# Imported source files and paths
CHIBIOS = ../../..
include $(CHIBIOS)/os/hal/hal.mk
include $(CHIBIOS)/os/hal/boards/ST_STM32373C_EVAL/board.mk
include $(CHIBIOS)/os/hal/ports/STM32/STM32F37x/platform.mk
include $(CHIBIOS)/os/hal/osal/rt/osal.mk
include $(CHIBIOS)/os/rt/rt.mk
include $(CHIBIOS)/os/rt/ports/ARMCMx/compilers/GCC/mk/port_stm32f37x.mk
include $(CHIBIOS)/test/rt/test.mk

# Define linker script file here
LDSCRIPT= $(PORTLD)/STM32F373xC.ld

# C sources that can be compiled in ARM or THUMB mode depending on the global
# setting.
CSRC = $(PORTSRC) \
       $(KERNSRC) \
       $(TESTSRC) \
       $(HALSRC) \
       $(OSALSRC) \
       $(PLATFORMSRC) \
       $(BOARDSRC) \
       main.c

# C++ sources that can be compiled in ARM or THUMB mode depending on the global
# setting.
CPPSRC =

# C sources to be compiled in ARM mode regardless of the global setting.
# NOTE: Mixing ARM and THUMB mode enables the -mthumb-interwork compiler
#       option that results in lower performance and larger code size.
ACSRC =

# C++ sources to be compiled in ARM mode regardless of the global setting.
# NOTE: Mixing ARM and THUMB mode enables the -mthumb-interwork compiler
#       option that results in lower performance and larger code size.
ACPPSRC =

# C sources to be compiled in THUMB mode regardless of the global setting.
# NOTE: Mixing ARM and THUMB mode enables the -mthumb-interwork compiler
#       option that results in lower performance and larger code size.
TCSRC =

# C sources to be compiled in THUMB mode regardless of the global setting.
# NOTE: Mixing ARM and THUMB mode enables the -mthumb-interwork compiler
#       option that results in lower performance and larger code size.
TCPPSRC =

# List ASM source files here
ASMSRC = $(PORTASM)

INCDIR = $(PORTINC) $(KERNINC) $(TESTINC) \
         $(HALINC) $(OSALINC) $(PLATFORMINC) $(BOARDINC) \
         $(CHIBIOS)/os/various

#
# Project, sources and paths
##############################################################################

##############################################################################
# Compiler settings
#

MCU  = cortex-m4

#TRGT = arm-elf-
TRGT = arm-none-eabi-
CC   = $(TRGT)gcc
CPPC = $(TRGT)g++
# Enable loading with g++ only if you need C++ runtime support.
# NOTE: You can use C++ even without C++ support if you are careful. C++
#       runtime support makes code size explode.
LD   = $(TRGT)gcc
#LD   = $(TRGT)g++
CP   = $(TRGT)objcopy
AS   = $(TRGT)gcc -x assembler-with-cpp
OD   = $(TRGT)objdump
SZ   = $(TRGT)size
HEX  = $(CP) -O ihex
BIN  = $(CP) -O binary

# ARM-specific options here
AOPT =

# THUMB-specific options here
TOPT = -mthumb -DTHUMB

# Define C warning options here
CWARN = -Wall -Wextra -Wstrict-prototypes

# Define C++ warning options here
CPPWARN = -Wall -Wextra

#
# Compiler settings
##############################################################################

##############################################################################
# Start of user section
#

# List all user C define here, like -D_DEBUG=1
UDEFS =

# Define ASM defines here
UADEFS =

# List all user directories here
UINCDIR =

# List the user directory to look for the libraries here
ULIBDIR =

# List all user libraries here
ULIBS =

#
# End of user defines
##############################################################################

RULESPATH = $(CHIBIOS)/os/common/ports/ARMCMx/compilers/GCC
include $(RULESPATH)/rules.mk
generated by cgit v1.2.3 (git 2.25.1) at 2026-01-08 12:14:37 +0000
(Library, Null_Identifier); Set_Identifier (Library, Ident); if Load_Library (Library) = False then Error_Msg_Sem (+Loc, "cannot find resource library %i", +Ident); end if; Set_Visible_Flag (Library, True); Set_Chain (Libraries_Chain_Last, Library); Libraries_Chain_Last := Library; return Library; end Get_Library; -- Return TRUE if UNIT1 and UNIT2 have identifiers for the same -- design unit identifier. -- eg: 'entity A' and 'package A' returns TRUE. function Is_Same_Library_Unit (Unit1, Unit2 : Iir) return Boolean is Entity_Name1, Entity_Name2: Name_Id; Unit1_Kind, Unit2_Kind : Iir_Kind; begin if Get_Identifier (Unit1) /= Get_Identifier (Unit2) then return False; end if; Unit1_Kind := Get_Kind (Unit1); Unit2_Kind := Get_Kind (Unit2); -- Package and package body are never the same library unit. if Unit1_Kind = Iir_Kind_Package_Declaration and then Unit2_Kind = Iir_Kind_Package_Body then return False; end if; if Unit2_Kind = Iir_Kind_Package_Declaration and then Unit1_Kind = Iir_Kind_Package_Body then return False; end if; -- Two architecture declarations are identical only if they also have -- the same entity name. if Unit1_Kind = Iir_Kind_Architecture_Body and then Unit2_Kind = Iir_Kind_Architecture_Body then Entity_Name1 := Get_Entity_Identifier_Of_Architecture (Unit1); Entity_Name2 := Get_Entity_Identifier_Of_Architecture (Unit2); if Entity_Name1 /= Entity_Name2 then return False; end if; end if; -- An architecture declaration never conflits with a library unit that -- is not an architecture declaration. if (Unit1_Kind = Iir_Kind_Architecture_Body and then Unit2_Kind /= Iir_Kind_Architecture_Body) or else (Unit1_Kind /= Iir_Kind_Architecture_Body and then Unit2_Kind = Iir_Kind_Architecture_Body) then return False; end if; return True; end Is_Same_Library_Unit; -- Return true iff DEP (an element of a dependence list) is design unit -- UNIT. function Is_Design_Unit (Dep : Iir; Unit : Iir) return Boolean is Lib_Unit : Iir; begin case Get_Kind (Dep) is when Iir_Kind_Design_Unit => return Dep = Unit; when Iir_Kind_Selected_Name => declare Lib : constant Iir := Get_Library (Get_Design_File (Unit)); begin if Get_Identifier (Get_Prefix (Dep)) /= Get_Identifier (Lib) then return False; end if; end; Lib_Unit := Get_Library_Unit (Unit); case Iir_Kinds_Library_Unit (Get_Kind (Lib_Unit)) is when Iir_Kinds_Primary_Unit | Iir_Kind_Package_Body | Iir_Kind_Foreign_Module => return Get_Identifier (Dep) = Get_Identifier (Lib_Unit); when Iir_Kind_Architecture_Body => return False; end case; when Iir_Kind_Entity_Aspect_Entity => Lib_Unit := Get_Library_Unit (Unit); if Get_Kind (Lib_Unit) /= Iir_Kind_Architecture_Body then return False; end if; if Get_Identifier (Get_Architecture (Dep)) /= Get_Identifier (Lib_Unit) then return False; end if; if Get_Entity (Dep) /= Get_Entity (Lib_Unit) then return False; end if; return True; when others => Error_Kind ("is_design_unit", Dep); end case; end Is_Design_Unit; function Find_Design_Unit (Unit : Iir) return Iir_Design_Unit is begin case Get_Kind (Unit) is when Iir_Kind_Design_Unit | Iir_Kind_Foreign_Module => return Unit; when Iir_Kind_Selected_Name => declare Lib : Iir_Library_Declaration; begin Lib := Get_Library (Get_Identifier (Get_Prefix (Unit)), Get_Location (Unit)); return Find_Primary_Unit (Lib, Get_Identifier (Unit)); end; when Iir_Kind_Entity_Aspect_Entity => return Find_Secondary_Unit (Get_Design_Unit (Get_Entity (Unit)), Get_Identifier (Get_Architecture (Unit))); when others => Error_Kind ("find_design_unit", Unit); end case; end Find_Design_Unit; function Find_Design_File (Lib : Iir_Library_Declaration; Name : Name_Id) return Iir is File : Iir; begin File := Get_Design_File_Chain (Lib); while Is_Valid (File) loop if Get_Design_File_Filename (File) = Name then return File; end if; File := Get_Chain (File); end loop; return Null_Iir; end Find_Design_File; -- Mark UNIT as obsolete. Mark all units that depends on UNIT as -- obsolete. procedure Mark_Unit_Obsolete (Unit : Iir_Design_Unit) is Lib, File, Un : Iir; List : Iir_List; It : List_Iterator; El : Iir; begin Set_Date (Unit, Date_Obsolete); Lib := Libraries_Chain; while Is_Valid (Lib) loop File := Get_Design_File_Chain (Lib); while Is_Valid (File) loop Un := Get_First_Design_Unit (File); while Is_Valid (Un) loop if Get_Kind (Un) /= Iir_Kind_Foreign_Module then List := Get_Dependence_List (Un); else List := Null_Iir_List; end if; if List /= Null_Iir_List and then Get_Date (Un) /= Date_Obsolete then pragma Assert (Get_Date_State (Un) = Date_Analyze); It := List_Iterate (List); while Is_Valid (It) loop El := Get_Element (It); if Is_Design_Unit (El, Unit) then -- Keep direct reference (for speed-up). if Get_Kind (El) /= Iir_Kind_Design_Unit then Vhdl.Utils.Free_Recursive (El); Set_Element (It, Unit); end if; -- Recurse. Mark_Unit_Obsolete (Un); end if; Next (It); end loop; end if; Un := Get_Chain (Un); end loop; File := Get_Chain (File); end loop; Lib := Get_Chain (Lib); end loop; end Mark_Unit_Obsolete; -- This procedure is called when the DESIGN_UNIT (either the stub created -- when a library is read or created from a previous unit in a source -- file) has been replaced by a new unit. Free everything but DESIGN_UNIT, -- because it may be referenced in other units (dependence...) -- FIXME: Isn't the library unit also referenced too ? procedure Free_Design_Unit (Design_Unit : Iir_Design_Unit) is Lib : Iir; Unit : Iir_Design_Unit; Dep_List : Iir_List; begin -- Free dependence list. Dep_List := Get_Dependence_List (Design_Unit); Destroy_Iir_List (Dep_List); Set_Dependence_List (Design_Unit, Null_Iir_List); -- Free default configuration of architecture (if any). Lib := Get_Library_Unit (Design_Unit); if Lib /= Null_Iir and then Get_Kind (Lib) = Iir_Kind_Architecture_Body then Free_Iir (Get_Entity_Name (Lib)); Unit := Get_Default_Configuration_Declaration (Lib); if Unit /= Null_Iir then Free_Design_Unit (Unit); end if; end if; -- Free library unit. Free_Iir (Lib); Set_Library_Unit (Design_Unit, Null_Iir); end Free_Design_Unit; procedure Remove_Unit_From_File (Unit_Ref : Iir_Design_Unit; File : Iir_Design_File) is Prev : Iir_Design_Unit; Unit, Next : Iir_Design_Unit; begin Prev := Null_Iir; Unit := Get_First_Design_Unit (File); while Unit /= Null_Iir loop Next := Get_Chain (Unit); if Unit = Unit_Ref then if Prev = Null_Iir then Set_First_Design_Unit (File, Next); else Set_Chain (Prev, Next); end if; if Next = Null_Iir then Set_Last_Design_Unit (File, Prev); end if; return; end if; Prev := Unit; Unit := Next; end loop; -- Not found. raise Internal_Error; end Remove_Unit_From_File; -- Add or replace a design unit in the working library. procedure Add_Design_Unit_Into_Library (Unit : in Iir_Design_Unit; Keep_Obsolete : Boolean := False) is Design_File: Iir_Design_File; Design_Unit, Prev_Design_Unit : Iir_Design_Unit; Last_Unit : Iir_Design_Unit; Library_Unit: Iir; New_Library_Unit: Iir; Unit_Id : Name_Id; Date: Date_Type; New_Lib_Checksum : File_Checksum_Id; Id : Hash_Id; -- File name and dir name of DECL. File_Name : Name_Id; Dir_Name : Name_Id; begin -- As specified, the Chain must be not set. pragma Assert (Get_Chain (Unit) = Null_Iir); -- The unit must not be in the library. pragma Assert (Get_Date_State (Unit) = Date_Extern); -- Mark this design unit as being loaded. case Get_Kind (Unit) is when Iir_Kind_Design_Unit => New_Library_Unit := Get_Library_Unit (Unit); when Iir_Kind_Foreign_Module => New_Library_Unit := Unit; when others => raise Internal_Error; end case; Unit_Id := Get_Identifier (New_Library_Unit); -- Set the date of the design unit as the most recently analyzed -- design unit. case Get_Date (Unit) is when Date_Parsed => Set_Date_State (Unit, Date_Parse); when Date_Analyzed => Date := Get_Date (Work_Library) + 1; Set_Date (Unit, Date); Set_Date (Work_Library, Date); Set_Date_State (Unit, Date_Analyze); when Date_Valid => raise Internal_Error; when others => raise Internal_Error; end case; -- Set file time stamp. declare File : constant Source_File_Entry := Get_Design_File_Source (Get_Design_File (Unit)); begin New_Lib_Checksum := Files_Map.Get_File_Checksum (File); File_Name := Files_Map.Get_File_Name (File); if GNAT.OS_Lib.Is_Absolute_Path (Image (File_Name)) then Dir_Name := Null_Identifier; else Dir_Name := Files_Map.Get_Home_Directory; end if; end; if Unit_Id = Null_Identifier then pragma Assert (Flags.Flag_Force_Analysis); return; end if; -- Try to find a design unit with the same name in the work library. Id := Get_Hash_Id_For_Unit (Unit); declare Design_Unit, Prev_Design_Unit : Iir_Design_Unit; Next_Design_Unit : Iir_Design_Unit; begin Design_Unit := Unit_Hash_Table (Id); Prev_Design_Unit := Null_Iir; while Design_Unit /= Null_Iir loop Next_Design_Unit := Get_Hash_Chain (Design_Unit); Design_File := Get_Design_File (Design_Unit); case Get_Kind (Design_Unit) is when Iir_Kind_Foreign_Module => Library_Unit := Design_Unit; when Iir_Kind_Design_Unit => Library_Unit := Get_Library_Unit (Design_Unit); when others => raise Internal_Error; end case; if Get_Identifier (Design_Unit) = Unit_Id and then Get_Library (Design_File) = Work_Library and then Is_Same_Library_Unit (New_Library_Unit, Library_Unit) then -- LIBRARY_UNIT and UNIT designate the same design unit. Mark_Unit_Obsolete (Design_Unit); -- Remove the old one from the hash table. -- Remove DESIGN_UNIT from the unit_hash. if Prev_Design_Unit = Null_Iir then Unit_Hash_Table (Id) := Next_Design_Unit; else Set_Hash_Chain (Prev_Design_Unit, Next_Design_Unit); end if; -- Remove DESIGN_UNIT from the design_file. -- If KEEP_OBSOLETE is True, units that are obsoleted by units -- in the same design file are kept. This allows to process -- (pretty print, xrefs, ...) all units of a design file. -- But still remove units that are replaced (if a file was -- already in the library). if not Keep_Obsolete or else Get_Date_State (Design_Unit) = Date_Disk then Remove_Unit_From_File (Design_Unit, Design_File); -- Put removed units in a list so that they are still -- referenced. Set_Chain (Design_Unit, Obsoleted_Design_Units); Obsoleted_Design_Units := Design_Unit; end if; -- UNIT *must* replace library_unit if they don't belong -- to the same file. if Get_Design_File_Filename (Design_File) = File_Name and then Get_Design_File_Directory (Design_File) = Dir_Name then -- In the same file. if Get_Date_State (Design_Unit) = Date_Analyze then -- Warns only if we are not re-analyzing the file. if Is_Warning_Enabled (Warnid_Library) then Warning_Msg_Sem (Warnid_Library, +Unit, "redefinition of a library unit in " & "same design file:"); Warning_Msg_Sem (Warnid_Library, +Unit, "%n defined at %l is now %n", (+Library_Unit, +Library_Unit, +New_Library_Unit)); end if; else -- Free the stub corresponding to the unit. This is the -- common case when a unit is reanalyzed after a change. if not Keep_Obsolete then Free_Design_Unit (Design_Unit); end if; end if; -- Note: the current design unit should not be freed if -- in use; unfortunatly, this is not obvious to check. else if Is_Warning_Enabled (Warnid_Library) and then Get_Kind (Library_Unit) in Iir_Kinds_Primary_Unit then if Get_Kind (Library_Unit) /= Get_Kind (New_Library_Unit) then Warning_Msg_Sem (Warnid_Library, +Unit, "changing definition of a library unit:"); Warning_Msg_Sem (Warnid_Library, +Unit, "%n is now %n", (+Library_Unit, +New_Library_Unit)); end if; Warning_Msg_Sem (Warnid_Library, +Unit, "%n was also defined in file %i", (+Library_Unit, +Get_Design_File_Filename (Design_File))); end if; end if; -- Continue to search as there can be several units with the -- same name (like package and package body). end if; Prev_Design_Unit := Design_Unit; Design_Unit := Next_Design_Unit; end loop; end; -- Try to find the design file in the library. -- First try the last one found. if Last_Design_File /= Null_Iir and then Get_Library (Last_Design_File) = Work_Library and then Get_Design_File_Filename (Last_Design_File) = File_Name and then Get_Design_File_Directory (Last_Design_File) = Dir_Name then Design_File := Last_Design_File; else -- Search. Design_File := Get_Design_File_Chain (Work_Library); while Design_File /= Null_Iir loop if Get_Design_File_Filename (Design_File) = File_Name and then Get_Design_File_Directory (Design_File) = Dir_Name then exit; end if; Design_File := Get_Chain (Design_File); end loop; Last_Design_File := Design_File; end if; if Design_File /= Null_Iir and then New_Lib_Checksum /= No_File_Checksum_Id and then not Files_Map.Is_Eq (New_Lib_Checksum, Get_File_Checksum (Design_File)) then -- FIXME: this test is not enough: what about reanalyzing -- unmodified files (this works only because the order is not -- changed). -- Design file is updated. -- Outdate all other units, overwrite the design_file. Set_File_Checksum (Design_File, New_Lib_Checksum); Design_Unit := Get_First_Design_Unit (Design_File); while Design_Unit /= Null_Iir loop if Design_Unit /= Unit then -- Mark other design unit as obsolete. Mark_Unit_Obsolete (Design_Unit); Remove_Unit_Hash (Design_Unit); else raise Internal_Error; end if; Prev_Design_Unit := Design_Unit; Design_Unit := Get_Chain (Design_Unit); -- Put it on the obsolete list so that it is always referenced. Set_Chain (Prev_Design_Unit, Obsoleted_Design_Units); Obsoleted_Design_Units := Prev_Design_Unit; end loop; Set_First_Design_Unit (Design_File, Null_Iir); Set_Last_Design_Unit (Design_File, Null_Iir); end if; if Design_File = Null_Iir then -- This is the first apparition of the design file. Design_File := Create_Iir (Iir_Kind_Design_File); Location_Copy (Design_File, Unit); Set_Design_File_Filename (Design_File, File_Name); Set_Design_File_Directory (Design_File, Dir_Name); Set_File_Checksum (Design_File, New_Lib_Checksum); Set_Parent (Design_File, Work_Library); Set_Chain (Design_File, Get_Design_File_Chain (Work_Library)); Set_Design_File_Chain (Work_Library, Design_File); end if; -- Add DECL to DESIGN_FILE. Last_Unit := Get_Last_Design_Unit (Design_File); if Last_Unit = Null_Iir then pragma Assert (Get_First_Design_Unit (Design_File) = Null_Iir); Set_First_Design_Unit (Design_File, Unit); else pragma Assert (Get_First_Design_Unit (Design_File) /= Null_Iir); Set_Chain (Last_Unit, Unit); end if; Set_Last_Design_Unit (Design_File, Unit); Set_Design_File (Unit, Design_File); -- Add DECL in unit hash table. Set_Hash_Chain (Unit, Unit_Hash_Table (Id)); Unit_Hash_Table (Id) := Unit; -- Update the analyzed time stamp. Set_Analysis_Time_Stamp (Design_File, Files_Map.Get_Os_Time_Stamp); end Add_Design_Unit_Into_Library; procedure Add_Design_File_Into_Library (File : in out Iir_Design_File) is Unit : Iir_Design_Unit; Next_Unit : Iir_Design_Unit; First_Unit : Iir_Design_Unit; begin Unit := Get_First_Design_Unit (File); First_Unit := Unit; Set_First_Design_Unit (File, Null_Iir); Set_Last_Design_Unit (File, Null_Iir); while Unit /= Null_Iir loop Next_Unit := Get_Chain (Unit); Set_Chain (Unit, Null_Iir); Libraries.Add_Design_Unit_Into_Library (Unit, True); Unit := Next_Unit; end loop; if First_Unit /= Null_Iir then File := Get_Design_File (First_Unit); end if; end Add_Design_File_Into_Library; -- Save the file map of library LIBRARY. procedure Save_Library (Library: Iir_Library_Declaration) is use System; use Interfaces.C_Streams; use GNAT.OS_Lib; Temp_Name: constant String := Image (Work_Directory) & '_' & Library_To_File_Name (Library) & ASCII.NUL; Mode : constant String := 'w' & ASCII.NUL; Stream : FILEs; Success : Boolean; -- Write a string to the temporary file. procedure WR (S : String) is Close_Res : int; pragma Unreferenced (Close_Res); begin if Integer (fwrite (S'Address, S'Length, 1, Stream)) /= 1 then Error_Lib_Msg ("cannot write library file for " & Image_Identifier (Library)); Close_Res := fclose (Stream); Delete_File (Temp_Name'Address, Success); -- Ignore failure to delete the file. raise Option_Error; end if; end WR; -- Write a line terminator in the temporary file. procedure WR_LF is begin WR (String'(1 => ASCII.LF)); end WR_LF; Design_File: Iir_Design_File; Design_Unit: Iir_Design_Unit; Library_Unit: Iir; Dir : Name_Id; Off, Line: Natural; Pos: Source_Ptr; Source_File : Source_File_Entry; begin -- Create a temporary file so that the real library is atomically -- updated, and won't be corrupted in case of Control-C, or concurrent -- writes. Stream := fopen (Temp_Name'Address, Mode'Address); if Stream = NULL_Stream then Error_Lib_Msg ("cannot create library file for " & Image_Identifier (Library)); raise Option_Error; end if; -- Header: version. WR ("v 4"); WR_LF; Design_File := Get_Design_File_Chain (Library); while Design_File /= Null_Iir loop -- Ignore std.standard as there is no corresponding file. if Design_File = Vhdl.Std_Package.Std_Standard_File then goto Continue; end if; Design_Unit := Get_First_Design_Unit (Design_File); if Design_Unit /= Null_Iir then WR ("file "); Dir := Get_Design_File_Directory (Design_File); if Dir = Null_Identifier then -- Absolute filenames. WR ("/"); elsif Work_Directory = Name_Nil and then Dir = Files_Map.Get_Home_Directory then -- If the library is in the current directory, do not write -- it. This allows to move the library file. WR ("."); else WR (""""); WR (Image (Dir)); WR (""""); end if; WR (" """); WR (Image (Get_Design_File_Filename (Design_File))); WR (""" """); WR (Files_Map.Get_File_Checksum_String (Get_File_Checksum (Design_File))); WR (""" """); WR (Files_Map.Get_Time_Stamp_String (Get_Analysis_Time_Stamp (Design_File))); WR (""":"); WR_LF; end if; while Design_Unit /= Null_Iir loop Library_Unit := Get_Library_Unit (Design_Unit); WR (" "); case Get_Kind (Library_Unit) is when Iir_Kind_Entity_Declaration => WR ("entity "); WR (Image_Identifier (Library_Unit)); when Iir_Kind_Architecture_Body => WR ("architecture "); WR (Image_Identifier (Library_Unit)); WR (" of "); WR (Image (Get_Entity_Identifier_Of_Architecture (Library_Unit))); when Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration => WR ("package "); WR (Image_Identifier (Library_Unit)); when Iir_Kind_Package_Body => WR ("package body "); WR (Image_Identifier (Library_Unit)); when Iir_Kind_Configuration_Declaration => WR ("configuration "); WR (Image_Identifier (Library_Unit)); when Iir_Kind_Context_Declaration => WR ("context "); WR (Image_Identifier (Library_Unit)); when Iir_Kind_Vunit_Declaration => WR ("vunit "); WR (Image_Identifier (Library_Unit)); when Iir_Kind_Vprop_Declaration => WR ("vprop "); WR (Image_Identifier (Library_Unit)); when Iir_Kind_Vmode_Declaration => WR ("vmode "); WR (Image_Identifier (Library_Unit)); when others => Error_Kind ("save_library", Library_Unit); end case; if Get_Date_State (Design_Unit) = Date_Disk then Pos := Get_Design_Unit_Source_Pos (Design_Unit); Line := Natural (Get_Design_Unit_Source_Line (Design_Unit)); Off := Natural (Get_Design_Unit_Source_Col (Design_Unit)); else Files_Map.Location_To_Coord (Get_Location (Design_Unit), Source_File, Pos, Line, Off); end if; WR (" at"); WR (Natural'Image (Line)); WR ("("); WR (Source_Ptr'Image (Pos)); WR (") +"); WR (Natural'Image (Off)); WR (" on"); WR (Date_Type'Image (Get_Date (Design_Unit))); case Get_Date (Design_Unit) is when Date_Valid | Date_Obsolete | Date_Analyzed | Date_Parsed => null; when others => raise Internal_Error; end case; if Get_Kind (Library_Unit) = Iir_Kind_Package_Declaration and then Get_Need_Body (Library_Unit) then WR (" body"); end if; WR (";"); WR_LF; Design_Unit := Get_Chain (Design_Unit); end loop; << Continue >> null; Design_File := Get_Chain (Design_File); end loop; declare Fclose_Res : int; pragma Unreferenced (Fclose_Res); begin Fclose_Res := fclose (Stream); end; -- Rename the temporary file to the library file. -- FIXME: It may fail if they aren't on the same filesystem, but we -- could assume it doesn't happen (humm...) declare File_Name: constant String := Image (Work_Directory) & Library_To_File_Name (Library) & ASCII.NUL; Delete_Success : Boolean; begin -- For windows: renames doesn't overwrite destination; so first -- delete it. This can create races condition on Unix: if the -- program is killed between delete and rename, the library is lost. Delete_File (File_Name'Address, Delete_Success); Rename_File (Temp_Name'Address, File_Name'Address, Success); if not Success then -- Renaming may fail if the new filename is in a non-existant -- directory. Error_Lib_Msg ("cannot update library file """ & File_Name (File_Name'First .. File_Name'Last - 1) & """"); Delete_File (Temp_Name'Address, Success); raise Option_Error; end if; end; end Save_Library; -- Save the map of the work library. procedure Save_Work_Library is begin Save_Library (Work_Library); end Save_Work_Library; -- Return the name of the latest architecture analysed for an entity. function Get_Latest_Architecture (Entity: Iir_Entity_Declaration) return Iir_Architecture_Body is Entity_Id : Name_Id; Lib : Iir_Library_Declaration; Design_File: Iir_Design_File; Design_Unit: Iir_Design_Unit; Library_Unit: Iir; Res: Iir_Design_Unit; begin -- FIXME: use hash Entity_Id := Get_Identifier (Entity); Lib := Get_Library (Get_Design_File (Get_Design_Unit (Entity))); Design_File := Get_Design_File_Chain (Lib); Res := Null_Iir; while Design_File /= Null_Iir loop Design_Unit := Get_First_Design_Unit (Design_File); while Design_Unit /= Null_Iir loop if Get_Kind (Design_Unit) = Iir_Kind_Design_Unit then Library_Unit := Get_Library_Unit (Design_Unit); if Get_Kind (Library_Unit) = Iir_Kind_Architecture_Body and then (Get_Entity_Identifier_Of_Architecture (Library_Unit) = Entity_Id) then if Res = Null_Iir then Res := Design_Unit; elsif Get_Date (Design_Unit) > Get_Date (Res) then Res := Design_Unit; end if; end if; end if; Design_Unit := Get_Chain (Design_Unit); end loop; Design_File := Get_Chain (Design_File); end loop; if Res = Null_Iir then return Null_Iir; else return Get_Library_Unit (Res); end if; end Get_Latest_Architecture; -- Return the declaration of primary unit NAME of LIBRARY. function Find_Primary_Unit (Library: Iir_Library_Declaration; Name: Name_Id) return Iir_Design_Unit is Unit : Iir_Design_Unit; Lib_Unit : Iir; begin Unit := Unit_Hash_Table (Name mod Unit_Hash_Length); while Unit /= Null_Iir loop if Get_Identifier (Unit) = Name and then Get_Library (Get_Design_File (Unit)) = Library then Lib_Unit := Get_Library_Unit (Unit); case Iir_Kinds_Library_Unit (Get_Kind (Lib_Unit)) is when Iir_Kinds_Primary_Unit | Iir_Kind_Foreign_Module => -- Only return a primary unit. return Unit; when Iir_Kinds_Secondary_Unit => null; end case; end if; Unit := Get_Hash_Chain (Unit); end loop; -- The primary unit is not in the library, return null. return Null_Iir; end Find_Primary_Unit; -- Return the declaration of secondary unit NAME for PRIMARY, or null if -- not found. function Find_Secondary_Unit (Primary: Iir_Design_Unit; Name: Name_Id) return Iir_Design_Unit is Lib_Prim : constant Iir := Get_Library (Get_Design_File (Primary)); Primary_Ident : constant Name_Id := Get_Identifier (Get_Library_Unit (Primary)); Design_Unit: Iir_Design_Unit; Library_Unit: Iir; begin Design_Unit := Unit_Hash_Table (Primary_Ident mod Unit_Hash_Length); while Design_Unit /= Null_Iir loop -- The secondary is always in the same library as the primary. if Get_Kind (Design_Unit) /= Iir_Kind_Foreign_Module and then Get_Library (Get_Design_File (Design_Unit)) = Lib_Prim then Library_Unit := Get_Library_Unit (Design_Unit); -- Set design_unit to null iff this is not the correct -- design unit. case Get_Kind (Library_Unit) is when Iir_Kind_Architecture_Body => -- The entity field can be either an identifier (if the -- library unit was not loaded) or an access to the entity -- unit. if (Get_Entity_Identifier_Of_Architecture (Library_Unit) = Primary_Ident) and then Get_Identifier (Library_Unit) = Name then return Design_Unit; end if; when Iir_Kind_Package_Body => if Name = Null_Identifier and then Get_Identifier (Library_Unit) = Primary_Ident then return Design_Unit; end if; when others => null; end case; end if; Design_Unit := Get_Hash_Chain (Design_Unit); end loop; -- The architecture or the body is not in the library, return null. return Null_Iir; end Find_Secondary_Unit; function Find_Entity_For_Component (Name: Name_Id) return Iir_Design_Unit is Res : Iir_Design_Unit := Null_Iir; Unit : Iir_Design_Unit; begin Res := Null_Iir; Unit := Unit_Hash_Table (Name mod Unit_Hash_Length); while Unit /= Null_Iir loop if Get_Identifier (Unit) = Name then case Get_Kind (Get_Library_Unit (Unit)) is when Iir_Kind_Entity_Declaration | Iir_Kind_Foreign_Module => if Res /= Null_Iir then -- Many entities. return Null_Iir; else Res := Unit; end if; when others => null; end case; end if; Unit := Get_Hash_Chain (Unit); end loop; return Res; end Find_Entity_For_Component; function Get_Libraries_Chain return Iir_Library_Declaration is begin return Libraries_Chain; end Get_Libraries_Chain; function Decode_Work_Option (Opt : String) return Name_Id is Name : String (Opt'First + 7 .. Opt'Last); Err : Boolean; begin Name := Opt (Opt'First + 7 .. Opt'Last); Vhdl.Scanner.Convert_Identifier (Name, Err); if Err then return Null_Identifier; end if; return Get_Identifier (Name); -- Libraries.Work_Library_Name := end Decode_Work_Option; end Libraries;