diff --git a/contrib/lkt/extensions/src/liblktlang-default_provider.adb b/contrib/lkt/extensions/src/liblktlang-default_provider.adb new file mode 100644 index 000000000..1c90a4e8d --- /dev/null +++ b/contrib/lkt/extensions/src/liblktlang-default_provider.adb @@ -0,0 +1,183 @@ +with Ada.Containers.Vectors; +with Ada.Directories; +with Ada.Environment_Variables; +with Ada.Strings.Unbounded; + +with Liblktlang.Common; use Liblktlang.Common; + +package body Liblktlang.Default_Provider is + + package Dirs renames Ada.Directories; + package Env renames Ada.Environment_Variables; + package US renames Ada.Strings.Unbounded; + package String_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => US.Unbounded_String, + "=" => US."="); + + type Default_Unit_Provider is new Internal_Unit_Provider with record + Ref_Count : Natural; + Directories : String_Vectors.Vector; + end record; + type Default_Unit_Provider_Access is access all Default_Unit_Provider; + + overriding procedure Inc_Ref (Self : in out Default_Unit_Provider); + overriding function Dec_Ref + (Self : in out Default_Unit_Provider) return Boolean; + overriding function Get_Unit_Filename + (Self : Default_Unit_Provider; + Name : Text_Type; + Kind : Analysis_Unit_Kind) return String; + overriding function Get_Unit + (Self : Default_Unit_Provider; + Context : Internal_Context; + Name : Text_Type; + Kind : Analysis_Unit_Kind; + Charset : String := ""; + Reparse : Boolean := False) return Internal_Unit; + + ------------- + -- Inc_Ref -- + ------------- + + overriding procedure Inc_Ref (Self : in out Default_Unit_Provider) is + begin + Self.Ref_Count := Self.Ref_Count + 1; + end Inc_Ref; + + ------------- + -- Dec_Ref -- + ------------- + + overriding function Dec_Ref + (Self : in out Default_Unit_Provider) return Boolean is + begin + Self.Ref_Count := Self.Ref_Count - 1; + return Self.Ref_Count = 0; + end Dec_Ref; + + ----------------------- + -- Get_Unit_Filename -- + ----------------------- + + overriding function Get_Unit_Filename + (Self : Default_Unit_Provider; + Name : Text_Type; + Kind : Analysis_Unit_Kind) return String + is + Base_Filename : constant String := Unit_Base_Filename (Name); + begin + -- There are only unit bodies in Lkt + if Kind /= Unit_Body or else Base_Filename = "" then + return ""; + end if; + + -- Return the first matching file in the list of directories + for Dir of Self.Directories loop + declare + Full : constant String := Dirs.Compose + (US.To_String (Dir), Base_Filename); + begin + if Dirs.Exists (Full) then + return Full; + end if; + end; + end loop; + + return ""; + end Get_Unit_Filename; + + -------------- + -- Get_Unit -- + -------------- + + overriding function Get_Unit + (Self : Default_Unit_Provider; + Context : Internal_Context; + Name : Text_Type; + Kind : Analysis_Unit_Kind; + Charset : String := ""; + Reparse : Boolean := False) return Internal_Unit + is + Filename : constant String := Self.Get_Unit_Filename (Name, Kind); + begin + if Filename = "" then + return Get_With_Error + (Context, + Unit_Base_Filename (Name), + "Cannot open source file", + Charset, + Default_Grammar_Rule); + end if; + + return Get_From_File + (Context, Filename, Charset, Reparse, Default_Grammar_Rule); + end Get_Unit; + + ------------------------ + -- Unit_Base_Filename -- + ------------------------ + + function Unit_Base_Filename (Name : Text_Type) return String is + Radix : String (Name'Range); + begin + -- Accept only names made of alphanumerics and underscores + for I in Name'Range loop + if Name (I) not in '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '_' then + return ""; + end if; + Radix (I) := Character'Val (Character_Type'Pos (Name (I))); + end loop; + return Radix & ".lkt"; + end Unit_Base_Filename; + + ------------ + -- Create -- + ------------ + + function Create return Internal_Unit_Provider_Access is + Result : constant Default_Unit_Provider_Access := + new Default_Unit_Provider'(Internal_Unit_Provider with + Ref_Count => 1, + Directories => <>); + Path : constant String := Env.Value (Path_Var_Name, ""); + + procedure Append (S : String); + -- If S is a non-empty string, append it as a lookup directory + + ------------ + -- Append -- + ------------ + + procedure Append (S : String) is + begin + if S /= "" then + Result.Directories.Append (US.To_Unbounded_String (S)); + end if; + end Append; + + begin + -- Sources in the current directory always come first + Append (Dirs.Current_Directory); + + if Path /= "" then + -- Import all semicolon-separated directories from the environment + -- variable as lookup directories. + + declare + First : Positive := Path'First; + begin + for I in Path'Range loop + if Path (I) = ':' then + Append (Path (First .. I - 1)); + First := I + 1; + end if; + end loop; + Append (Path (First .. Path'Last)); + end; + end if; + + return Internal_Unit_Provider_Access (Result); + end Create; + +end Liblktlang.Default_Provider; diff --git a/contrib/lkt/extensions/src/liblktlang-default_provider.ads b/contrib/lkt/extensions/src/liblktlang-default_provider.ads new file mode 100644 index 000000000..04cf81fc9 --- /dev/null +++ b/contrib/lkt/extensions/src/liblktlang-default_provider.ads @@ -0,0 +1,23 @@ +with Langkit_Support.Text; use Langkit_Support.Text; + +with Liblktlang.Implementation; use Liblktlang.Implementation; + +-- This package provides the default unit provider for Lkt contexts. This +-- provider behaves similarly to CPython's mechanism to find modules: use an +-- environment variable (LKT_PATH) that contains a list of directories in +-- which to find Lkt source files. + +private package Liblktlang.Default_Provider is + + Path_Var_Name : constant String := "LKT_PATH"; + -- Name of the environment variable that contains the path to Lkt source + -- files. + + function Unit_Base_Filename (Name : Text_Type) return String; + -- Return the base filename corresponding to this unit name, or an empty + -- string if Name is not a valid unit name. + + function Create return Internal_Unit_Provider_Access; + -- Create a new default unit provider instance + +end Liblktlang.Default_Provider; diff --git a/contrib/lkt/manage.py b/contrib/lkt/manage.py index bbc2ccbdf..e7c8e2591 100755 --- a/contrib/lkt/manage.py +++ b/contrib/lkt/manage.py @@ -7,15 +7,20 @@ from langkit.libmanage import ManageScript class Manage(ManageScript): def create_context(self, args): - from langkit.compile_context import CompileCtx + from langkit.compile_context import CompileCtx, LibraryEntity from language.lexer import lkt_lexer from language.parser import lkt_grammar - return CompileCtx(lang_name='lkt', - short_name='lkt', - lexer=lkt_lexer, - grammar=lkt_grammar) + return CompileCtx( + lang_name='lkt', + short_name='lkt', + lexer=lkt_lexer, + grammar=lkt_grammar, + default_unit_provider=LibraryEntity( + 'Liblktlang.Default_Provider', 'Create' + ) + ) if __name__ == '__main__': Manage().run()