diff --git a/Makefile b/Makefile
index fade8eb18..bcd2a7f7a 100644
--- a/Makefile
+++ b/Makefile
@@ -28,18 +28,15 @@ endif
ADDITIONAL_MANAGE_ARGS=
# WARNING: Note that for some reason parallelizing the build still doesn't work
-all: lkql lkql_checker lalcheck doc lkql_native_jit
+all: lkql gnatcheck lkql_native_jit doc
lkql: build/bin/liblkqllang_parse
-doc: lkql
+doc: lkql_native_jit
cd user_manual && make clean html
-lkql_checker: lkql
- gprbuild -P lkql_checker/lkql_checker.gpr -p $(GPR_ARGS) -XBUILD_MODE=$(BUILD_MODE)
-
-lalcheck: lkql
- gprbuild -P lkql_checker/lalcheck.gpr -p $(GPR_ARGS) -XBUILD_MODE=$(BUILD_MODE)
+gnatcheck: lkql
+ gprbuild -P lkql_checker/gnatcheck.gpr -p $(GPR_ARGS) -XBUILD_MODE=$(BUILD_MODE)
build/bin/liblkqllang_parse: lkql/language/parser.py lkql/language/lexer.py
lkql/manage.py make -P --pass-on="emit railroad diagrams" --enable-build-warnings --build-mode=$(BUILD_MODE) --enable-java --maven-executable $(MAVEN) $(ADDITIONAL_MANAGE_ARGS)
@@ -47,14 +44,11 @@ build/bin/liblkqllang_parse: lkql/language/parser.py lkql/language/lexer.py
test:
testsuite/testsuite.py -Edtmp
-clean: clean_lkql_checker clean_lkql clean_lkql_jit
+clean: clean_lkql clean_lkql_jit
clean_lkql:
rm lkql/build -rf
-clean_lkql_checker:
- gprclean -P lkql_checker/lkql_checker.gpr
-
clean_lkql_jit:
cd lkql_jit && $(MAVEN) clean
@@ -72,17 +66,11 @@ automated:
rm -rf "$(PREFIX)"
mkdir -p "$(PREFIX)/share" "$(PREFIX)/share/examples" "$(PREFIX)/lib"
$(PYTHON) lkql/manage.py make $(MANAGE_ARGS) $(ADDITIONAL_MANAGE_ARGS)
- $(GPRBUILD) -Plkql_checker/lkql_checker.gpr -largs -s
- $(GPRBUILD) -Plkql_checker/lalcheck.gpr -largs -s
- $(GPRBUILD) -Plkql/liblkqllang_encapsulated -XLIBRARY_TYPE=static-pic -largs -s
- $(GPRINSTALL) --mode=usage -Plkql_checker/lkql_checker.gpr
- $(GPRINSTALL) --mode=usage -Plkql_checker/lalcheck.gpr
+ $(GPRBUILD) -Plkql_checker/gnatcheck.gpr -largs -s
+ $(GPRINSTALL) --mode=usage -Plkql_checker/gnatcheck.gpr
$(GPRINSTALL) --mode=usage -P$(LKQL_DIR)/mains.gpr
cp -pr lkql_checker/share/lkql "$(PREFIX)/share"
cp -pr lkql_checker/share/examples "$(PREFIX)/share/examples/gnatcheck"
- cp -p lkql_repl.py "$(PREFIX)/bin"
- cp -pr "$(BUILD_DIR)/lkql/python" "$(PREFIX)/lib"
- cp -p lkql/encapsulated/*$(SOEXT) "$(PREFIX)/lib/python/liblkqllang"
automated-cov:
rm -rf "$(PREFIX)" "$(BUILD_DIR)"
diff --git a/lkql/extensions/analysis/bodies b/lkql/extensions/analysis/bodies
deleted file mode 100644
index 34b7edbed..000000000
--- a/lkql/extensions/analysis/bodies
+++ /dev/null
@@ -1,33 +0,0 @@
-## vim: ft=makoada
-
-function Get_Extension (Node : Lkql_Node'Class) return Extension_Type_Access
-is
- procedure Register_Destroyable is new Register_Destroyable_Gen
- (Extension_Type, Extension_Type_Access, Destroy);
- Ret : Extension_Type_Access;
- pragma Import (C, Ret);
- for Ret'Address use Unwrap_Node (Node).Ext'Address;
-begin
- -- Allocate the extension record if the field is null
- if Ret = null then
- Ret := new Extension_Type;
- -- Register it as a destroyable under the unit
- Register_Destroyable (Unwrap_Node (Node).Unit, Ret);
- end if;
-
- return Ret;
-end Get_Extension;
-
-procedure Init_Extension (Node : Lkql_Node'Class) is
- -- Define a dummy access type ..
- type Dummy_Access is access all Integer;
-
- -- .. and create an overlay variable ..
- Ret : Dummy_Access;
- pragma Import (C, Ret);
- for Ret'Address use Unwrap_Node (Node).Ext'Address;
-begin
- -- In order to initialize the address field to null without adding an import
- -- to System.Null_Address.
- Ret := null;
-end Init_Extension;
diff --git a/lkql/extensions/analysis/public_decls b/lkql/extensions/analysis/public_decls
deleted file mode 100644
index 1583b8881..000000000
--- a/lkql/extensions/analysis/public_decls
+++ /dev/null
@@ -1,15 +0,0 @@
-## vim: ft=makoada
-
-type Extension_Base is tagged null record;
-
-generic
- type Extension_Type is new Extension_Base with private;
- type Extension_Type_Access is access all Extension_Type;
- with procedure Destroy (El : in out Extension_Type_Access) is <>;
-function Get_Extension (Node : Lkql_Node'Class) return Extension_Type_Access;
--- Internal ``Get_Extension`` function: allocate and return a record derived
--- from ``Extension_Base``.
-
-procedure Init_Extension (Node : Lkql_Node'Class);
--- Initialization function, needed because the raw pointer field is not
--- actually initialized during node allocation.
diff --git a/lkql/extensions/mains/lkql_ada.adb b/lkql/extensions/mains/lkql_ada.adb
deleted file mode 100644
index e6d57351b..000000000
--- a/lkql/extensions/mains/lkql_ada.adb
+++ /dev/null
@@ -1,155 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Directories; use Ada.Directories;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-
-with GNATCOLL.Opt_Parse;
-
-with Langkit_Support.Diagnostics; use Langkit_Support.Diagnostics;
-with Langkit_Support.Diagnostics.Output;
-
-with Libadalang.Helpers; use Libadalang.Helpers;
-with Libadalang.Generic_API;
-
-with Liblkqllang.Analysis;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with LKQL.Primitives; use LKQL.Primitives;
-with LKQL.Evaluation; use LKQL.Evaluation;
-with LKQL.Errors; use LKQL.Errors;
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-with LKQL.Unit_Utils; use LKQL.Unit_Utils;
-
-----------
--- Main --
-----------
-
-procedure Lkql_Ada is
-
- use LKQL;
-
- package L renames Liblkqllang.Analysis;
-
- procedure Job_Setup (Context : App_Job_Context);
-
- procedure Job_Post_Process
- (Context : App_Job_Context);
-
- procedure Evaluate
- (Context : Eval_Context; Lkql_Script : L.Lkql_Node);
-
- package App is new Libadalang.Helpers.App
- (Name => "lkql_ada_interpreter",
- Description => "LKQL Ada interpreter",
- Enable_Parallelism => True,
- Job_Post_Process => Job_Post_Process,
- Job_Setup => Job_Setup);
-
- Lkql_Unit : L.Analysis_Unit;
-
- package Args is
- use GNATCOLL.Opt_Parse;
-
- package Script_Path is new Parse_Option
- (Parser => App.Args.Parser,
- Long => "--script-path",
- Short => "-S",
- Arg_Type => Unbounded_String,
- Help => "Path of the LKQL script to evaluate",
- Default_Val => Null_Unbounded_String);
- -- We use an option rt. a positional arg because we cannot add any more
- -- positional args to the App parser.
- end Args;
-
- Interpreter_Context : Eval_Context;
-
- ---------------
- -- Job_Setup --
- ---------------
-
- procedure Job_Setup (Context : App_Job_Context)
- is
- begin
- null;
- end Job_Setup;
-
- --------------
- -- Evaluate --
- --------------
-
- procedure Evaluate
- (Context : Eval_Context; Lkql_Script : L.Lkql_Node)
- is
- Ignore : Primitive;
- begin
- Ignore := Eval (Context, Lkql_Script);
- exception
- when Stop_Evaluation_Error =>
- pragma Assert (Is_Error (Context.Last_Error),
- "Stop Evaluation Error raised without adding the " &
- "error to the evaluation context");
-
- declare
- N : L.Lkql_Node renames Context.Last_Error.AST_Node;
- D : constant Diagnostic := Langkit_Support.Diagnostics.Create
- (N.Sloc_Range,
- To_Text (Context.Last_Error.Short_Message));
- begin
- Output.Print_Diagnostic
- (D, N.Unit, Simple_Name (N.Unit.Get_Filename));
- end;
- end Evaluate;
-
- ----------------------
- -- App_Post_Process --
- ----------------------
-
- procedure Job_Post_Process
- (Context : App_Job_Context)
- is
- Roots : LK.Lk_Node_Array
- (Context.Units_Processed.First_Index ..
- Context.Units_Processed.Last_Index);
- begin
- for J in Roots'Range loop
- Roots (J) := Libadalang.Generic_API.To_Generic_Unit
- (Context.Units_Processed (J)).Root;
- end loop;
-
- Interpreter_Context := Make_Eval_Context
- (Roots,
- Libadalang.Generic_API.Ada_Lang_Id);
-
- Lkql_Unit := Make_Lkql_Unit
- (Interpreter_Context, To_String (Args.Script_Path.Get));
-
- Evaluate (Interpreter_Context, Lkql_Unit.Root);
- Interpreter_Context.Free_Eval_Context;
- exception
- when Unit_Creation_Error => null;
- end Job_Post_Process;
-
-begin
- App.Run;
-end Lkql_Ada;
diff --git a/lkql/extensions/nodes/lkql_node/components b/lkql/extensions/nodes/lkql_node/components
deleted file mode 100644
index b36145388..000000000
--- a/lkql/extensions/nodes/lkql_node/components
+++ /dev/null
@@ -1,2 +0,0 @@
-Ext : System.Address;
--- Untyped pointer to the extension record
diff --git a/lkql/extensions/src/funcs.adb b/lkql/extensions/src/funcs.adb
deleted file mode 100644
index f31a10f8c..000000000
--- a/lkql/extensions/src/funcs.adb
+++ /dev/null
@@ -1,67 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package body Funcs is
-
- --------------------
- -- Release_Access --
- --------------------
-
- procedure Release_Access (F : in out Func_Access) is
- begin
- if F /= null then
- F.Release;
- Free_Func (F);
- end if;
- end Release_Access;
-
- --------------
- -- Evaluate --
- --------------
-
- function Evaluate (Self : in out Ada_Func_Wrapper;
- Element : Argument_Type) return Return_Type
- is
- begin
- return Self.Fn (Element);
- end Evaluate;
-
- -----------
- -- Clone --
- -----------
-
- function Clone (Self : Ada_Func_Wrapper) return Ada_Func_Wrapper is
- begin
- return Ada_Func_Wrapper'(Fn => Self.Fn);
- end Clone;
-
- -------------
- -- To_Func --
- -------------
-
- function To_Func (Fn : Ada_Func_Access) return Ada_Func_Wrapper is
- begin
- return Ada_Func_Wrapper'(Fn => Fn);
- end To_Func;
-
-end Funcs;
diff --git a/lkql/extensions/src/funcs.ads b/lkql/extensions/src/funcs.ads
deleted file mode 100644
index cdfa1fc47..000000000
--- a/lkql/extensions/src/funcs.ads
+++ /dev/null
@@ -1,81 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Deallocation;
-generic
-
- type Argument_Type (<>) is private;
- -- Function's argument type
-
- type Return_Type (<>) is private;
- -- Function's return type
-
-package Funcs is
-
- type Func is interface;
- -- Abstraction representing a function that takes Element_Type values
- -- and returns values of type Return_Type.
-
- type Func_Access is access all Func'Class;
- -- Pointer to a Func
-
- function Evaluate (Self : in out Func;
- Element : Argument_Type)
- return Return_Type is abstract;
- -- Apply the current Func to Element
-
- function Clone (Self : Func) return Func is abstract;
- -- Perform a deep copy of the given Func
-
- procedure Release (Self : in out Func) is null;
- -- Release resources that belong to Self
-
- procedure Release_Access (F : in out Func_Access);
- -- Release the resources of the function that is accessed through 'F',
- -- the free 'F' itself.
-
- procedure Free_Func is new Ada.Unchecked_Deallocation
- (Func'Class, Func_Access);
- -- Free the memory accessed through a Func_Access pointer
-
- type Ada_Func_Access is access
- function (X : Argument_Type) return Return_Type;
- -- Pointer to an Ada function that takes an Element_Type value and
- -- returns a Return_Type value.
-
- type Ada_Func_Wrapper is new Func with private;
-
- function Evaluate (Self : in out Ada_Func_Wrapper;
- Element : Argument_Type) return Return_Type;
-
- function Clone (Self : Ada_Func_Wrapper) return Ada_Func_Wrapper;
-
- function To_Func (Fn : Ada_Func_Access) return Ada_Func_Wrapper;
-
-private
-
- type Ada_Func_Wrapper is new Func with record
- Fn : Ada_Func_Access;
- end record;
-
-end Funcs;
diff --git a/lkql/extensions/src/iters-adapters.adb b/lkql/extensions/src/iters-adapters.adb
deleted file mode 100644
index d0455c81e..000000000
--- a/lkql/extensions/src/iters-adapters.adb
+++ /dev/null
@@ -1,86 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package body Iters.Adapters is
-
- ------------------
- -- Wrapped_Iter --
- ------------------
-
- function Wrapped_Iter
- (Iter : Filter_Adapter) return Wrapped_Iters.Iterator_Access
- is
- (Iter.Wrapped);
-
- ----------
- -- Next --
- ----------
-
- function Next (Iter : in out Filter_Adapter;
- Result : out Wrapped_Iters.Element_Type)
- return Boolean
- is
- Element : Wrapped_Iters.Element_Type;
- begin
- if Iter.Wrapped.Next (Element)
- and then Iter.Filter_Fn (Iter.Wrapped, Element)
- then
- Result := Element;
- return True;
- else
- return False;
- end if;
- end Next;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Iter : in out Filter_Adapter) is
- begin
- Wrapped_Iters.Release_Access (Iter.Wrapped);
- end Release;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone (Iter : Filter_Adapter) return Filter_Adapter is
- Wrapped_Clone : constant Wrapped_Iters.Iterator_Access :=
- new Wrapped_Iters.Iterator_Interface'Class'
- (Wrapped_Iters.Iterator_Interface'Class (Iter.Wrapped.Clone));
- begin
- return Filter_Adapter'(Wrapped_Clone, Iter.Filter_Fn);
- end Clone;
-
- -------------------------
- -- Make_Filter_Adapter --
- -------------------------
-
- function Make_Filter_Adapter (Iter : Wrapped_Iters.Iterator_Access;
- Fn : Filter_Func_Access)
- return Filter_Adapter
- is
- (Filter_Adapter'(Iter, Fn));
-
-end Iters.Adapters;
diff --git a/lkql/extensions/src/iters-adapters.ads b/lkql/extensions/src/iters-adapters.ads
deleted file mode 100644
index 8a0846eff..000000000
--- a/lkql/extensions/src/iters-adapters.ads
+++ /dev/null
@@ -1,61 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Iters.Iterators;
-
-generic
-
- with package Wrapped_Iters is new Iters.Iterators (<>);
-
-package Iters.Adapters is
-
- type Filter_Func_Access is access
- function (Iter : in out Wrapped_Iters.Iterator_Access;
- Value : Wrapped_Iters.Element_Type)
- return Boolean;
-
- type Filter_Adapter is new Wrapped_Iters.Iterator_Interface with private;
-
- overriding function Next (Iter : in out Filter_Adapter;
- Result : out Wrapped_Iters.Element_Type)
- return Boolean;
-
- overriding function Clone (Iter : Filter_Adapter) return Filter_Adapter;
-
- overriding procedure Release (Iter : in out Filter_Adapter);
-
- function Wrapped_Iter
- (Iter : Filter_Adapter) return Wrapped_Iters.Iterator_Access;
-
- function Make_Filter_Adapter (Iter : Wrapped_Iters.Iterator_Access;
- Fn : Filter_Func_Access)
- return Filter_Adapter;
-
-private
-
- type Filter_Adapter is new Wrapped_Iters.Iterator_Interface with record
- Wrapped : Wrapped_Iters.Iterator_Access;
- Filter_Fn : Filter_Func_Access;
- end record;
-
-end Iters.Adapters;
diff --git a/lkql/extensions/src/iters-iterators.adb b/lkql/extensions/src/iters-iterators.adb
deleted file mode 100644
index 046fb30da..000000000
--- a/lkql/extensions/src/iters-iterators.adb
+++ /dev/null
@@ -1,289 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package body Iters.Iterators is
-
- -------------
- -- Consume --
- -------------
-
- function Consume (Iter : Iterator_Interface'Class) return Element_Array
- is
- Vec : Element_Vectors.Vector;
- Element : Element_Type;
- begin
- -- Note: This is bad design in Ada: We're hiding mutation of the
- -- Iterator object, because if we make it mutable, then you can no
- -- longer call consume on an expression that returns an Iterator, which
- -- in user APIs is not very friendly, because it means you cannot write
- -- write::
- --
- -- for Element of Node.Find (...).Consume loop
- -- ...
- -- end loop;
- --
- -- You have to declare the iterator explicitly.
-
- while Iter'Unrestricted_Access.Next (Element) loop
- Vec.Append (Element);
- end loop;
-
- Iter'Unrestricted_Access.Release;
-
- return Result : Element_Array (1 .. Natural (Vec.Length)) do
- for I in Result'Range loop
- Result (I) := Vec.Element (I);
- end loop;
- end return;
- end Consume;
-
- --------------------
- -- Release_Access --
- --------------------
-
- procedure Release_Access (Iter : in out Iterator_Access) is
- begin
- if Iter /= null then
- Iter.all.Release;
- Free_Iterator (Iter);
- end if;
- end Release_Access;
-
- --------------------
- -- Filtered_Count --
- --------------------
-
- function Filtered_Count (Iter : Filter_Iter) return Natural is
- (Iter.Nb_Filtered);
-
- ----------
- -- Next --
- ----------
-
- function Next
- (Iter : in out Filter_Iter; Result : out Element_Type) return Boolean
- is
- Current_Element : Element_Type;
- begin
- while Iter.Inner.Next (Current_Element) loop
- if Iter.Predicate.Evaluate (Current_Element) then
- Result := Current_Element;
- return True;
- else
- Iter.Nb_Filtered := Iter.Nb_Filtered + 1;
- end if;
- end loop;
-
- return False;
- end Next;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone (Iter : Filter_Iter) return Filter_Iter
- is
- Predicate_Copy : constant Predicates.Func_Access :=
- new Predicates.Func'Class'
- (Predicates.Func'Class (Iter.Predicate.Clone));
- Inner_Copy : constant Iterator_Access :=
- new Iterator_Interface'Class'
- (Iterator_Interface'Class (Iter.Inner.Clone));
- begin
- return Filter_Iter'(Inner_Copy, Predicate_Copy, 0);
- end Clone;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Iter : in out Filter_Iter) is
- begin
- Release_Access (Iter.Inner);
- Predicates.Release_Access (Iter.Predicate);
- end Release;
-
- ------------
- -- Filter --
- ------------
-
- function Filter
- (Iter : Iterator_Access; Pred : Predicate_Access) return Filter_Iter
- is
- begin
- return (Inner => Iter, Predicate => Pred, Nb_Filtered => 0);
- end Filter;
-
- ------------
- -- Filter --
- ------------
-
- function Filter (Iter : Iterator_Interface'Class;
- Pred : Predicates.Func'Class)
- return Filter_Iter
- is
- Iter_Ptr : constant Iterator_Access :=
- new Iterator_Interface'Class'(Iter);
- Pred_Ptr : constant Predicate_Access :=
- new Predicates.Func'Class'(Pred);
- begin
- return Filter (Iter_Ptr, Pred_Ptr);
- end Filter;
-
- function Read_From_Inner (Iter : in out Resetable_Iter;
- Result : out Element_Type) return Boolean;
- -- Read a value from the resetable iterator's inner iterator
-
- function Read_From_Cache (Iter : in out Resetable_Iter;
- Result : out Element_Type) return Boolean;
- -- Read a value from the resetable iterator's cache
-
- ----------
- -- Next --
- ----------
-
- overriding function Next (Iter : in out Resetable_Iter;
- Result : out Element_Type) return Boolean
- is
- begin
- return (if Iter.Cache_Pos = -1
- then Read_From_Inner (Iter, Result)
- else Read_From_Cache (Iter, Result));
- end Next;
-
- ---------------------
- -- Read_From_Inner --
- ---------------------
-
- function Read_From_Inner (Iter : in out Resetable_Iter;
- Result : out Element_Type) return Boolean
- is
- begin
- if Iter.Inner.Next (Result) then
- Iter.Cache.Append (Result);
- return True;
- else
- return False;
- end if;
- end Read_From_Inner;
-
- ---------------------
- -- Read_From_Cache --
- ---------------------
-
- function Read_From_Cache (Iter : in out Resetable_Iter;
- Result : out Element_Type) return Boolean
- is
- begin
- if Iter.Cache.Is_Empty or Iter.Cache_Pos > Iter.Cache.Last_Index then
- return False;
- end if;
-
- Result := Iter.Cache.all (Iter.Cache_Pos);
- Iter.Cache_Pos := Iter.Cache_Pos + 1;
- return True;
- end Read_From_Cache;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Iter : in out Resetable_Iter) is
- begin
- Free_Element_Vector (Iter.Cache);
- Iter.Inner.Release;
- Free_Iterator (Iter.Inner);
- end Release;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone (Iter : Resetable_Iter) return Resetable_Iter is
- Inner_Copy : constant Iterator_Access :=
- new Iterator_Interface'Class'
- (Iterator_Interface'Class (Iter.Inner.Clone));
- Cache_Copy : constant Element_Vector_Access :=
- new Element_Vectors.Vector'(Iter.Cache.all);
- begin
- return (Inner_Copy, Cache_Copy, Iter.Cache_Pos);
- end Clone;
-
- ------------------
- -- Cache_Length --
- ------------------
-
- function Cache_Length (Iter : Resetable_Iter) return Natural is
- (Natural (Iter.Cache.Length));
-
- -----------
- -- Inner --
- -----------
-
- function Get_Inner (Iter : Resetable_Iter) return Iterator_Access is
- (Iter.Inner);
-
- ----------------
- -- Get_Cached --
- ----------------
-
- function Get_Cached
- (Iter : Resetable_Iter; Pos : Positive) return Element_Option
- is
- begin
- if Pos <= Iter.Cache_Length then
- return Element_Options.To_Option (Iter.Cache.Element (Pos));
- else
- return Element_Options.None;
- end if;
- end Get_Cached;
-
- -----------
- -- Reset --
- -----------
-
- procedure Reset (Iter : in out Resetable_Iter) is
- begin
- Iter.Cache_Pos := 1;
- end Reset;
- ---------------
- -- Resetable --
- ---------------
-
- function Resetable (Iter : Iterator_Interface'Class) return Resetable_Iter
- is
- begin
- return Resetable_Iter'
- (Inner => new Iterator_Interface'Class'(Iter), others => <>);
- end Resetable;
-
- ---------------
- -- Resetable --
- ---------------
-
- function Resetable (Iter : Iterator_Access) return Resetable_Iter is
- begin
- return Resetable_Iter'(Inner => Iter, others => <>);
- end Resetable;
-
-end Iters.Iterators;
diff --git a/lkql/extensions/src/iters-iterators.ads b/lkql/extensions/src/iters-iterators.ads
deleted file mode 100644
index c14352f68..000000000
--- a/lkql/extensions/src/iters-iterators.ads
+++ /dev/null
@@ -1,198 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Funcs;
-with Options;
-
-with Ada.Unchecked_Deallocation;
-with Ada.Containers.Vectors;
-
-generic
-
- type Element_Type is private;
- -- Type of the values yielded by the iterator
-
-package Iters.Iterators is
-
- type Element_Array is array (Positive range <>) of Element_Type;
- -- Array type to use when consuming the iterator into an array of elements
-
- package Element_Vectors is new Ada.Containers.Vectors
- (Positive, Element_Type);
- -- Vectors of Element_Type values
-
- type Element_Vector_Access is access all Element_Vectors.Vector;
- -- Pointer to a vector of Element_Type values
-
- package Element_Options is new Options (Element_Type);
- -- Optional Element_Type values
-
- subtype Element_Option is Element_Options.Option;
- -- Optional Element_Type value
-
- --------------
- -- Iterator --
- --------------
-
- type Iterator_Interface is interface;
- -- Abstraction for iterating over a sequence of values
-
- type Iterator_Access is access all Iterator_Interface'Class;
-
- function Next (Iter : in out Iterator_Interface;
- Result : out Element_Type) return Boolean is abstract;
- -- Get the next iteration element. If there was no element to yield
- -- anymore, return false. Otherwise, return true and set Result.
-
- function Clone
- (Iter : Iterator_Interface) return Iterator_Interface is abstract;
- -- Make a deep copy of the iterator
-
- procedure Release (Iter : in out Iterator_Interface) is null;
- -- Release resources that belong to Iter
-
- function Consume (Iter : Iterator_Interface'Class) return Element_Array;
- -- Consume the iterator and return an array that contains the yielded
- -- elements.
- --
- -- The ressources associated with the iterator will be released.
-
- procedure Release_Access (Iter : in out Iterator_Access);
- -- Release the ressources that belong to the iterator accessed trough
- -- 'Iter', then free 'Iter' itself.
-
- procedure Free_Iterator is new Ada.Unchecked_Deallocation
- (Iterator_Interface'Class, Iterator_Access);
-
- ---------------
- -- Consumers --
- ---------------
-
- generic
-
- type Return_Type (<>) is private;
- -- Type of values produced by the iterator's consumption
-
- package Consumers is
-
- type Consumer_Interface is interface;
-
- function Consume (Self : in out Consumer_Interface;
- Iter : in out Iterator_Interface'Class)
- return Return_Type is abstract;
- -- Consume and release the iterator
-
- end Consumers;
-
- ------------
- -- Filter --
- ------------
-
- package Predicates is new Funcs (Element_Type, Boolean);
- -- Function that takes an Element_Type argument an retrurns a Boolean
-
- subtype Predicate_Access is Predicates.Func_Access;
- -- Pointer to a predicate
-
- type Filter_Iter is new Iterator_Interface with private;
- -- Iterator that wraps an other iterator an filters it's elements using a
- -- Predicate.
-
- function Filtered_Count (Iter : Filter_Iter) return Natural;
- -- Return the number of filtered elements
-
- overriding function Next (Iter : in out Filter_Iter;
- Result : out Element_Type) return Boolean;
-
- overriding function Clone (Iter : Filter_Iter) return Filter_Iter;
-
- overriding procedure Release (Iter : in out Filter_Iter);
-
- function Filter
- (Iter : Iterator_Access; Pred : Predicate_Access) return Filter_Iter;
-
- function Filter (Iter : Iterator_Interface'Class;
- Pred : Predicates.Func'Class)
- return Filter_Iter;
-
- ---------------
- -- Resetable --
- ---------------
-
- type Resetable_Iter is new Iterator_Interface with private;
- -- Resetable iterator that caches the elements that it yields.
-
- type Resetable_Access is access all Resetable_Iter;
-
- overriding function Next (Iter : in out Resetable_Iter;
- Result : out Element_Type) return Boolean;
-
- overriding procedure Release (Iter : in out Resetable_Iter);
-
- overriding function Clone (Iter : Resetable_Iter) return Resetable_Iter;
-
- function Get_Cached
- (Iter : Resetable_Iter; Pos : Positive) return Element_Option;
- -- Get the cached element at Pos, if it exists
-
- function Cache_Length (Iter : Resetable_Iter) return Natural;
- -- Return the number of cached elements
-
- function Get_Inner (Iter : Resetable_Iter) return Iterator_Access;
- -- Return an access to the wrapped iterator
-
- procedure Reset (Iter : in out Resetable_Iter);
- -- Reset the iterator. Further calls to 'Next' will yield the cached
- -- elements.
-
- function Resetable (Iter : Iterator_Interface'Class) return Resetable_Iter;
-
- function Resetable (Iter : Iterator_Access) return Resetable_Iter;
-
-private
-
- procedure Free_Predicate_Access is new Ada.Unchecked_Deallocation
- (Predicates.Func'Class, Predicate_Access);
-
- type Filter_Iter is new Iterator_Interface with record
- Inner : Iterator_Access;
- Predicate : Predicate_Access;
- Nb_Filtered : Natural := 0;
- end record;
-
- procedure Free_Element_Vector is new Ada.Unchecked_Deallocation
- (Element_Vectors.Vector, Element_Vector_Access);
-
- subtype Cache_Index is Integer range -1 .. Integer'Last;
-
- type Resetable_Iter is new Iterator_Interface with record
- Inner : Iterator_Access;
- -- Wrapped iterator
- Cache : Element_Vector_Access := new Element_Vectors.Vector;
- -- Cached values
- Cache_Pos : Cache_Index := -1;
- -- Index of the next cache value to read.
- -- -1 if the wrapped iterator hasn't been fully consumed yet
- end record;
-
-end Iters.Iterators;
diff --git a/lkql/extensions/src/iters-maps.adb b/lkql/extensions/src/iters-maps.adb
deleted file mode 100644
index e3f29a73f..000000000
--- a/lkql/extensions/src/iters-maps.adb
+++ /dev/null
@@ -1,94 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package body Iters.Maps is
-
- ----------
- -- Next --
- ----------
-
- overriding function Next (Iter : in out Map_Iter;
- Result : out Result_Type) return Boolean
- is
- Input_Element : Input_Iterators.Element_Type;
- Input_Exists : constant Boolean := Iter.Inner.Next (Input_Element);
- begin
- if not Input_Exists then
- return False;
- end if;
-
- Result := Iter.Fn.Evaluate (Input_Element);
- return True;
- end Next;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone (Iter : Map_Iter) return Map_Iter is
- Fn_Copy : constant Map_Funcs.Func_Access :=
- new Map_Funcs.Func'Class'(Map_Funcs.Func'Class (Iter.Fn.Clone));
- Inner_Copy : constant Input_Iterators.Iterator_Access :=
- new Input_Iterators.Iterator_Interface'Class'
- (Input_Iterators.Iterator_Interface'Class (Iter.Inner.Clone));
- begin
- return Map_Iter'(Inner_Copy, Fn_Copy);
- end Clone;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Iter : in out Map_Iter) is
- begin
- Map_Funcs.Release_Access (Iter.Fn);
- Input_Iterators.Release_Access (Iter.Inner);
- end Release;
-
- ---------
- -- Map --
- ---------
-
- function Map (Input : Input_Iterators.Iterator_Access;
- Fn : Map_Funcs.Func_Access) return Map_Iter
- is
- begin
- return Map_Iter'(Input, Fn);
- end Map;
-
- ---------
- -- Map --
- ---------
-
- function Map (Input : Input_Iterators.Iterator_Interface'Class;
- Fn : Map_Funcs.Func'Class) return Map_Iter
- is
- Input_Ptr : constant Input_Iterators.Iterator_Access :=
- new Input_Iterators.Iterator_Interface'Class'(Input);
- Fn_Ptr : constant Map_Funcs.Func_Access :=
- new Map_Funcs.Func'Class'(Fn);
- begin
- return Map_Iter'(Input_Ptr, Fn_Ptr);
- end Map;
-
-end Iters.Maps;
diff --git a/lkql/extensions/src/iters-maps.ads b/lkql/extensions/src/iters-maps.ads
deleted file mode 100644
index 0c1cf15fa..000000000
--- a/lkql/extensions/src/iters-maps.ads
+++ /dev/null
@@ -1,70 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Funcs;
-with Iters.Iterators;
-
-generic
-
- with package Input_Iterators is new Iters.Iterators (<>);
- -- Wrapped iterators
-
- with package Output_Iterators is new Iters.Iterators (<>);
- -- Wrapped iterators
-
-package Iters.Maps is
-
- subtype Result_Type is Output_Iterators.Element_Type;
-
- package Map_Funcs is new Funcs (Input_Iterators.Element_Type, Result_Type);
- -- Abstraction representing a function that takes values from the input
- -- iterator and returns values of type Return_Type.
-
- subtype Map_Func is Map_Funcs.Func;
-
- package Predicates renames Output_Iterators.Predicates;
-
- type Map_Iter is new Output_Iterators.Iterator_Interface with private;
- -- Iterator that maps a function over the elements of a given iterator
-
- overriding function Next (Iter : in out Map_Iter;
- Result : out Result_Type) return Boolean;
-
- overriding function Clone (Iter : Map_Iter) return Map_Iter;
-
- overriding procedure Release (Iter : in out Map_Iter);
-
- function Map (Input : Input_Iterators.Iterator_Access;
- Fn : Map_Funcs.Func_Access) return Map_Iter;
-
- function Map (Input : Input_Iterators.Iterator_Interface'Class;
- Fn : Map_Funcs.Func'Class) return Map_Iter;
-
-private
-
- type Map_Iter is new Output_Iterators.Iterator_Interface with record
- Inner : Input_Iterators.Iterator_Access;
- Fn : Map_Funcs.Func_Access;
- end record;
-
-end Iters.Maps;
diff --git a/lkql/extensions/src/iters-vec_iterators.adb b/lkql/extensions/src/iters-vec_iterators.adb
deleted file mode 100644
index 135778dd2..000000000
--- a/lkql/extensions/src/iters-vec_iterators.adb
+++ /dev/null
@@ -1,73 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package body Iters.Vec_Iterators is
-
- ----------
- -- Next --
- ----------
-
- overriding function Next (Iter : in out Vec_Iterator;
- Result : out Vectors.Element_Type) return Boolean
- is
- Cursor : constant Vectors.Cursor :=
- Iter.Elements.To_Cursor (Iter.Next_Element_Index);
- begin
- if not Vectors.Has_Element (Cursor) then
- return False;
- end if;
-
- Result := Vectors.Element (Cursor);
- Iter.Next_Element_Index :=
- Vectors.Extended_Index'Succ (Iter.Next_Element_Index);
- return True;
- end Next;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone (Iter : Vec_Iterator) return Vec_Iterator is
- Elements_Copy : constant Vec_Access :=
- new Vectors.Vector'(Iter.Elements.all);
- begin
- return Vec_Iterator'(Elements_Copy, Iter.Next_Element_Index);
- end Clone;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Iter : in out Vec_Iterator) is
- begin
- Free_Vec_Access (Iter.Elements);
- end Release;
-
- -----------------
- -- To_Iterator --
- -----------------
-
- function To_Iterator (Vec : Vectors.Vector) return Vec_Iterator is
- (Vec_Iterator'(new Vectors.Vector'(Vec), Vec.First_Index));
-
-end Iters.Vec_Iterators;
diff --git a/lkql/extensions/src/iters-vec_iterators.ads b/lkql/extensions/src/iters-vec_iterators.ads
deleted file mode 100644
index 6cb0cd447..000000000
--- a/lkql/extensions/src/iters-vec_iterators.ads
+++ /dev/null
@@ -1,69 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Iters.Iterators;
-
-with Ada.Containers.Vectors;
-with Ada.Unchecked_Deallocation;
-
-generic
-
- with package Vectors is new Ada.Containers.Vectors (<>);
- -- Type of vectors that we want to iterate over
-
- with package Iterators is new Iters.Iterators (Vectors.Element_Type);
- -- Type of iterators in which the vector will be wrapped
-
-package Iters.Vec_Iterators is
-
- type Vec_Iterator is new Iterators.Iterator_Interface with private;
- -- Iterator that yields the values contained in a vector
-
- overriding function Next (Iter : in out Vec_Iterator;
- Result : out Vectors.Element_Type) return Boolean;
- -- Get the next iteration element. If all the values from the vector have
- -- already been yielded, return false. Otherwise, return true and set
- -- Result.
-
- overriding function Clone (Iter : Vec_Iterator) return Vec_Iterator;
- -- Make a deep copy of the iterator
-
- overriding procedure Release (Iter : in out Vec_Iterator);
- -- Release resources that belong to Iter
-
- function To_Iterator (Vec : Vectors.Vector) return Vec_Iterator;
- -- Create a Vec_Iterator that wraps 'Vec'
-
-private
-
- type Vec_Access is access all Vectors.Vector;
-
- procedure Free_Vec_Access is new Ada.Unchecked_Deallocation
- (Vectors.Vector, Vec_Access);
-
- type Vec_Iterator is new Iterators.Iterator_Interface with record
- Elements : Vec_Access;
- Next_Element_Index : Vectors.Extended_Index;
- end record;
-
-end Iters.Vec_Iterators;
diff --git a/lkql/extensions/src/iters.ads b/lkql/extensions/src/iters.ads
deleted file mode 100644
index 3cefdaa9b..000000000
--- a/lkql/extensions/src/iters.ads
+++ /dev/null
@@ -1,26 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package Iters is
-
-end Iters;
diff --git a/lkql/extensions/src/liblkqllang-implementation-extensions.adb b/lkql/extensions/src/liblkqllang-implementation-extensions.adb
deleted file mode 100644
index 245b4ae13..000000000
--- a/lkql/extensions/src/liblkqllang-implementation-extensions.adb
+++ /dev/null
@@ -1,349 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Directories; use Ada.Directories;
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Strings.Wide_Wide_Unbounded; use Ada.Strings.Wide_Wide_Unbounded;
-
-with GNATCOLL.Projects; use GNATCOLL.Projects;
-
-with Langkit_Support.Diagnostics.Output;
-with Langkit_Support.Text; use Langkit_Support.Text;
-with Langkit_Support.Symbols; use Langkit_Support.Symbols;
-
-with Liblkqllang.Analysis;
-with Liblkqllang.Public_Converters;
-
-with Libadalang.Project_Provider; use Libadalang.Project_Provider;
-with Libadalang.Helpers; use Libadalang.Helpers;
-with Libadalang.Analysis; use Libadalang.Analysis;
-with Libadalang.Generic_API;
-
-with LKQL.Evaluation;
-with LKQL.Primitives; use LKQL.Primitives;
-with LKQL.Errors;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with LKQL.Unit_Utils;
-
-package body Liblkqllang.Implementation.Extensions is
-
- use LKQL;
-
- function Get_All_Completions_For_Id
- (Id : LKI.Type_Ref;
- In_Pattern : Boolean := False) return Unbounded_Text_Array;
- -- Get all valid completions (fields & properties) for a given
- -- Node_Type_Id.
-
- function Roots return LK.Lk_Node_Array;
- -- Return all the units for the LKQL context.
-
- function Eval
- (Ctx : Eval_Context; Node : Analysis.Lkql_Node'Class)
- return Primitive;
- -- Evaluate the given node in the given context. Also ensures that
- -- the unit in which ``Node`` belongs has been pre-processed.
-
- function Node_Kind_Names return Unbounded_Text_Array;
-
- function Make_Sym_Array
- (Strings : Unbounded_Text_Array) return Symbol_Type_Array_Access;
-
- -- TODO: for the moment the state is global, we need to store it in the
- -- LKQL context.
- Ctx : LK.Lk_Context;
- Files : String_Vectors.Vector;
- Lkql_Ctx : Eval_Context;
- Project : Project_Tree_Access;
- Env : Project_Environment_Access;
- Init : Boolean := False;
-
- ---------------------
- -- Node_Kind_Names --
- ---------------------
-
- function Node_Kind_Names return Unbounded_Text_Array is
- use LKI;
-
- Root_Node_Type : constant Type_Ref :=
- LKI.Root_Node_Type (Ctx.Language);
- First_Index : constant Type_Index := To_Index (Root_Node_Type);
- Last_Derived_Type_Index : constant Type_Index :=
- Last_Derived_Type (Root_Node_Type);
- begin
- return Ret : Unbounded_Text_Array
- (Positive (First_Index) .. Positive (Last_Derived_Type_Index))
- do
- for I in First_Index .. Last_Derived_Type_Index loop
- Ret (Positive (I)) := To_Unbounded_Text
- (LKN.Format_Name
- (Node_Type_Name
- (From_Index (Ctx.Language, I)), LKN.Camel));
- end loop;
- end return;
- end Node_Kind_Names;
-
- -----------
- -- Roots --
- -----------
-
- function Roots return LK.Lk_Node_Array is
- Ret : LK.Lk_Node_Array (1 .. Natural (Files.Length));
- begin
- for J in Ret'First .. Ret'Last loop
- Ret (J) :=
- Ctx .Get_From_File (To_String (Files (J))).Root;
- end loop;
-
- return Ret;
- end Roots;
-
- ----------
- -- Eval --
- ----------
-
- function Eval
- (Ctx : Eval_Context; Node : Analysis.Lkql_Node'Class)
- return Primitive
- is
- begin
- LKQL.Unit_Utils.Run_Preprocessor (Ctx, Node.Unit);
- return LKQL.Evaluation.Eval (Ctx, Node);
- end Eval;
-
- ------------------------------------------
- -- Lkql_Node_P_Interp_Init_From_Project --
- ------------------------------------------
-
- function Lkql_Node_P_Interp_Init_From_Project
- (Node : Bare_Lkql_Node; Project_File : String_Type) return Boolean
- is
- UFP : Unit_Provider_Reference;
- begin
- -- If already init, it means this is called for a second time: In that
- -- case we want to reinitialize.
- if Init then
- -- No need to explicitly finalize Analysis context, since it's a
- -- controlled type.
-
- -- Free the LKQL eval context
- Free_Eval_Context (Lkql_Ctx);
-
- Free (Project);
- Free (Env);
- end if;
-
- Libadalang.Helpers.Load_Project
- (Image (Project_File.Content), Project => Project, Env => Env);
-
- Files := Source_Files (Project.all);
-
- UFP := Project_To_Provider (Project);
- Ctx := Libadalang.Generic_API.To_Generic_Context
- (Create_Context (Charset => "utf-8", Unit_Provider => UFP));
-
- -- Use the context from this node to create the LKQL context.
- Lkql_Ctx := Make_Eval_Context
- (Roots,
- Libadalang.Generic_API.Ada_Lang_Id,
- Public_Converters.Wrap_Context (Node.Unit.Context));
-
- Init := True;
- return True;
- end Lkql_Node_P_Interp_Init_From_Project;
-
- -----------------------------
- -- Lkql_Node_P_Interp_Eval --
- -----------------------------
-
- function Lkql_Node_P_Interp_Eval (Node : Bare_Lkql_Node) return Symbol_Type
- is
- Public_Unit : constant Analysis.Analysis_Unit
- := Public_Converters.Wrap_Unit (Node.Unit);
- begin
- if Node.Unit.Diagnostics.Length > 0 then
- for Diag of Node.Unit.Diagnostics loop
- Langkit_Support.Diagnostics.Output.Print_Diagnostic
- (Diag,
- Public_Unit,
- Simple_Name (Public_Unit.Get_Filename));
- end loop;
- return null;
- end if;
-
- return Find
- (Node.Unit.Context.Symbols,
- To_Text
- (To_Unbounded_Text
- (Eval (Lkql_Ctx, Public_Converters.Wrap_Node (Node)))));
- exception
- when E : LKQL.Errors.Stop_Evaluation_Error =>
- return Find (Node.Unit.Context.Symbols,
- To_Text (": " & Exception_Message (E)));
- end Lkql_Node_P_Interp_Eval;
-
- --------------------------------
- -- Get_All_Completions_For_Id --
- --------------------------------
-
- function Get_All_Completions_For_Id
- (Id : LKI.Type_Ref;
- In_Pattern : Boolean := False) return Unbounded_Text_Array
- is
- Members : constant LKI.Struct_Member_Ref_Array := LKI.Members (Id);
- Ret : Unbounded_Text_Array (Members'Range);
- begin
- for J in Members'Range loop
- declare
- Val : Unbounded_Text_Type :=
- To_Unbounded_Text
- (LKN.Format_Name
- (LKI.Member_Name (Members (J)), LKN.Lower));
- begin
- if In_Pattern then
- Append (Val, "=");
- end if;
- end;
- end loop;
-
- return Ret;
- end Get_All_Completions_For_Id;
-
- --------------------
- -- Make_Sym_Array --
- --------------------
-
- function Make_Sym_Array
- (Strings : Unbounded_Text_Array) return Symbol_Type_Array_Access
- is
- Ret : constant Symbol_Type_Array_Access :=
- Create_Symbol_Type_Array (Strings'Length);
-
- Idx : Positive := 1;
- begin
- for S of Strings loop
- Ret.Items (Idx) := Symbol (Lkql_Ctx, To_Text (S));
- Idx := Idx + 1;
- end loop;
-
- return Ret;
- end Make_Sym_Array;
-
- ---------------------------------
- -- Lkql_Node_P_Interp_Complete --
- ---------------------------------
-
- function Lkql_Node_P_Interp_Complete
- (Node : Bare_Lkql_Node) return Symbol_Type_Array_Access
- is
-
- use Liblkqllang.Analysis;
-
- PNode : constant Lkql_Node := Public_Converters.Wrap_Node (Node);
- Last_Token : constant Token_Kind := Kind (Data (PNode.Token_End));
-
- begin
-
- -- Implement runtime based completion (a la IPython/etc) based on the
- -- syntactic content of the string.
-
- case Node.Kind is
-
- when Lkql_Query =>
-
- -- select |
-
- if Last_Token not in Lkql_Select_Tok then
- return No_Symbol_Type_Array_Type;
- end if;
-
- return Make_Sym_Array (Node_Kind_Names);
-
- when Lkql_Node_Pattern_Property
- | Lkql_Node_Pattern_Field =>
-
- -- Node(a=|
- -- Node(a() is |
-
- if Last_Token not in Lkql_Eq | Lkql_Is then
- return No_Symbol_Type_Array_Type;
- end if;
-
- return Make_Sym_Array (Node_Kind_Names);
-
- when Lkql_Extended_Node_Pattern =>
-
- -- Node(|
-
- if Last_Token not in Lkql_L_Par | Lkql_Coma then
- return No_Symbol_Type_Array_Type;
- end if;
-
- declare
- VP : constant Value_Pattern :=
- PNode.As_Extended_Node_Pattern.F_Node_Pattern;
- begin
- if VP.Kind = Lkql_Node_Kind_Pattern then
- return Make_Sym_Array
- (Get_All_Completions_For_Id
- (Lkql_Ctx.Get_Name_Map.Lookup_Type
- (Lkql_Ctx.Symbol
- (VP.As_Node_Kind_Pattern.F_Kind_Name.Text))));
- else
- return No_Symbol_Type_Array_Type;
- end if;
- end;
-
- when Lkql_Dot_Access =>
- declare
- LHS : constant Analysis.Expr := PNode.As_Dot_Access.F_Receiver;
- begin
-
- -- a.|
- -- where a is a dot access/simple identifier, not a complex expr
-
- if Last_Token /= Lkql_Dot
- or else LHS.Kind not in
- Lkql_Dot_Access | Lkql_Identifier | Lkql_Safe_Access
- then
- return No_Symbol_Type_Array_Type;
- end if;
-
- declare
- Val : constant Primitive := Eval (Lkql_Ctx, LHS);
- begin
- if Val.Kind = Kind_Node then
- return Make_Sym_Array
- (Get_All_Completions_For_Id (LKI.Type_Of (Val.Node_Val)));
- end if;
- end;
-
- return No_Symbol_Type_Array_Type;
-
- end;
- when others =>
- return No_Symbol_Type_Array_Type;
- end case;
- end Lkql_Node_P_Interp_Complete;
-
-end Liblkqllang.Implementation.Extensions;
diff --git a/lkql/extensions/src/liblkqllang-implementation-extensions.ads b/lkql/extensions/src/liblkqllang-implementation-extensions.ads
deleted file mode 100644
index fea6b3550..000000000
--- a/lkql/extensions/src/liblkqllang-implementation-extensions.ads
+++ /dev/null
@@ -1,37 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package Liblkqllang.Implementation.Extensions is
-
- type Unbounded_Text_Array
- is array (Positive range <>) of Unbounded_Text_Type;
-
- function Lkql_Node_P_Interp_Init_From_Project
- (Node : Bare_Lkql_Node; Project_File : String_Type) return Boolean;
-
- function Lkql_Node_P_Interp_Eval (Node : Bare_Lkql_Node) return Symbol_Type;
-
- function Lkql_Node_P_Interp_Complete
- (Node : Bare_Lkql_Node) return Symbol_Type_Array_Access;
-
-end Liblkqllang.Implementation.Extensions;
diff --git a/lkql/extensions/src/liblkqllang-prelude.adb b/lkql/extensions/src/liblkqllang-prelude.adb
deleted file mode 100644
index cbfef5562..000000000
--- a/lkql/extensions/src/liblkqllang-prelude.adb
+++ /dev/null
@@ -1,70 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-with LKQL.Unit_Utils;
-
-package body Liblkqllang.Prelude is
-
- Prelude_Content : constant String :=
- "selector next_siblings" & ASCII.LF &
- " |"" Yields the siblings following the given node in the tree"
- & ASCII.LF &
- " | AdaNode => rec this.next_sibling()" & ASCII.LF &
- " | * => ()" & ASCII.LF &
- "" & ASCII.LF &
- "selector prev_siblings" & ASCII.LF &
- " |"" Yields the siblings preceding the given node in the tree"
- & ASCII.LF &
- " | AdaNode => rec this.previous_sibling()" & ASCII.LF &
- " | * => ()" & ASCII.LF &
- "" & ASCII.LF &
- "selector parent" & ASCII.LF &
- " |"" Yields the parents (ancestors) of the given node in the tree"
- & ASCII.LF &
- " | AdaNode => rec *this.parent" & ASCII.LF &
- " | * => ()" & ASCII.LF &
- "" & ASCII.LF &
- "selector children" & ASCII.LF &
- " |"" Yields all the descendants of the given node in the tree"
- & ASCII.LF &
- " | AdaNode => rec *this.children" & ASCII.LF &
- " | * => ()" & ASCII.LF &
- "" & ASCII.LF &
- "selector super_types" & ASCII.LF &
- " |"" Given a TypeDecl node, yields all the super types of the type"
- & ASCII.LF &
- " | BaseTypeDecl => rec *this.p_base_types()" & ASCII.LF &
- " | * => ()" & ASCII.LF;
-
- ------------------
- -- Prelude_Unit --
- ------------------
-
- function Prelude_Unit
- (Eval_Ctx : LKQL.Eval_Contexts.Eval_Context) return Analysis_Unit
- is
- begin
- return LKQL.Unit_Utils.Make_Lkql_Unit_From_Code
- (Eval_Ctx, Prelude_Content, "prelude");
- end Prelude_Unit;
-
-end Liblkqllang.Prelude;
diff --git a/lkql/extensions/src/liblkqllang-prelude.ads b/lkql/extensions/src/liblkqllang-prelude.ads
deleted file mode 100644
index 295c98c4d..000000000
--- a/lkql/extensions/src/liblkqllang-prelude.ads
+++ /dev/null
@@ -1,32 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Liblkqllang.Analysis; use Liblkqllang.Analysis;
-with LKQL.Eval_Contexts;
-
-package Liblkqllang.Prelude is
-
- function Prelude_Unit
- (Eval_Ctx : LKQL.Eval_Contexts.Eval_Context) return Analysis_Unit;
-
-end Liblkqllang.Prelude;
diff --git a/lkql/extensions/src/lkql-adaptive_integers.adb b/lkql/extensions/src/lkql-adaptive_integers.adb
deleted file mode 100644
index acba9864f..000000000
--- a/lkql/extensions/src/lkql-adaptive_integers.adb
+++ /dev/null
@@ -1,274 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package body LKQL.Adaptive_Integers is
- Int_First_Big : constant Big_Integer := To_Big_Integer (Integer'First);
- Int_Last_Big : constant Big_Integer := To_Big_Integer (Integer'Last);
-
- function Create (Value : Big_Integer) return Adaptive_Integer;
- -- Create an Adaptive_Integer from a Big_Integer
-
- function To_Big_Integer (Int : Adaptive_Integer) return Big_Integer;
- -- Return the given Adaptive_Integer as a Big_Integer, performing
- -- the conversion if necessary.
-
- ------------
- -- Create --
- ------------
-
- function Create (Value : Integer) return Adaptive_Integer is
- begin
- return (Kind => Small, Small_Value => Value);
- end Create;
-
- ------------
- -- Create --
- ------------
-
- function Create (Value : Big_Integer) return Adaptive_Integer is
- begin
- return (Kind => Big, Big_Value => Value);
- end Create;
-
- ------------
- -- Create --
- ------------
-
- function Create (Value : String) return Adaptive_Integer is
- begin
- return (Kind => Small, Small_Value => Integer'Value (Value));
- exception
- when Constraint_Error =>
- return (Kind => Big, Big_Value => From_String (Value));
- end Create;
-
- -----------
- -- Image --
- -----------
-
- function Image (Int : Adaptive_Integer) return String is
- begin
- case Int.Kind is
- when Small =>
- return Int.Small_Value'Image;
- when Big =>
- return To_String (Int.Big_Value);
- end case;
- end Image;
-
- --------------------
- -- To_Big_Integer --
- --------------------
-
- function To_Big_Integer (Int : Adaptive_Integer) return Big_Integer is
- begin
- if Int.Kind = Small then
- return To_Big_Integer (Int.Small_Value);
- else
- return Int.Big_Value;
- end if;
- end To_Big_Integer;
-
- ---------
- -- "+" --
- ---------
-
- function "+" (Int : Adaptive_Integer) return Integer is
- begin
- if Int.Kind = Small then
- return Int.Small_Value;
- else
- return To_Integer (Int.Big_Value);
- end if;
- end "+";
-
- generic
- with function Small_Op (L, R : Integer) return Boolean;
- with function Big_Op (L, R : Big_Integer) return Boolean;
- function Dispatch_Rel_Op
- (L, R : Adaptive_Integer) return Boolean;
- -- Generic implementation of relational operations on adaptive integers
-
- ---------------------
- -- Dispatch_Rel_Op --
- ---------------------
-
- function Dispatch_Rel_Op
- (L, R : Adaptive_Integer) return Boolean
- is
- begin
- case L.Kind is
- when Small =>
- case R.Kind is
- when Small =>
- return Small_Op (L.Small_Value, R.Small_Value);
- when Big =>
- return Big_Op
- (To_Big_Integer (L.Small_Value), R.Big_Value);
- end case;
- when Big =>
- case R.Kind is
- when Small =>
- return Big_Op
- (L.Big_Value, To_Big_Integer (R.Small_Value));
- when Big =>
- return Big_Op (L.Big_Value, R.Big_Value);
- end case;
- end case;
- end Dispatch_Rel_Op;
-
- package Implementation is
- function "=" is new Dispatch_Rel_Op ("=", "=");
- function "<" is new Dispatch_Rel_Op ("<", "<");
- function "<=" is new Dispatch_Rel_Op ("<=", "<=");
- function ">" is new Dispatch_Rel_Op (">", ">");
- function ">=" is new Dispatch_Rel_Op (">=", ">=");
- end Implementation;
-
- ---------
- -- "=" --
- ---------
-
- function "=" (L, R : Adaptive_Integer) return Boolean
- renames Implementation."=";
-
- ---------
- -- "<" --
- ---------
-
- function "<" (L, R : Adaptive_Integer) return Boolean
- renames Implementation."<";
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (L, R : Adaptive_Integer) return Boolean
- renames Implementation."<=";
-
- ---------
- -- ">" --
- ---------
-
- function ">" (L, R : Adaptive_Integer) return Boolean
- renames Implementation.">";
-
- ----------
- -- ">=" --
- ----------
-
- function ">=" (L, R : Adaptive_Integer) return Boolean
- renames Implementation.">=";
-
- ---------
- -- "-" --
- ---------
-
- function "-" (L : Adaptive_Integer) return Adaptive_Integer is
- begin
- case L.Kind is
- when Small =>
- -- Check for overflow
- declare
- X : constant Integer := L.Small_Value;
- begin
- if X = Integer'First then
- -- overflow
- return Create (-To_Big_Integer (X));
- else
- return (Kind => Small, Small_Value => -X);
- end if;
- end;
- when Big =>
- return (Kind => Big, Big_Value => -L.Big_Value);
- end case;
- end "-";
-
- ---------
- -- "+" --
- ---------
-
- function "+" (L, R : Adaptive_Integer) return Adaptive_Integer is
- begin
- if L.Kind = Small and R.Kind = Small then
- -- Check for overflow
- declare
- X : constant Integer := L.Small_Value;
- Y : constant Integer := R.Small_Value;
- begin
- if (X > 0 and then Y > Integer'Last - X) or else
- (X < 0 and then Y < Integer'First - X)
- then
- -- overflow
- return Create (To_Big_Integer (X) + To_Big_Integer (Y));
- else
- return Create (X + Y);
- end if;
- end;
- end if;
-
- -- If any of the operands is a big integer, perform the computation
- -- on two big integers.
- return Create (To_Big_Integer (L) + To_Big_Integer (R));
- end "+";
-
- ---------
- -- "-" --
- ---------
-
- function "-" (L, R : Adaptive_Integer) return Adaptive_Integer is
- (L + (-R));
-
- ---------
- -- "*" --
- ---------
-
- function "*" (L, R : Adaptive_Integer) return Adaptive_Integer is
- -- Always do the multiplication in big integer space, as checking
- -- for multiplication overflow is quite complicated.
- P : constant Big_Integer := To_Big_Integer (L) * To_Big_Integer (R);
- begin
- if L.Kind = Small and R.Kind = Small then
- if In_Range (P, Int_First_Big, Int_Last_Big) then
- return Create (To_Integer (P));
- end if;
- end if;
- return Create (P);
- end "*";
-
- ---------
- -- "/" --
- ---------
-
- function "/" (L, R : Adaptive_Integer) return Adaptive_Integer is
- begin
- if L.Kind = Small and R.Kind = Small then
- -- Check for the only possible overflow
- if L.Small_Value /= Integer'First or else R.Small_Value /= -1 then
- return Create (L.Small_Value / R.Small_Value);
- end if;
- end if;
- return Create (To_Big_Integer (L) / To_Big_Integer (R));
- end "/";
-
-end LKQL.Adaptive_Integers;
diff --git a/lkql/extensions/src/lkql-adaptive_integers.ads b/lkql/extensions/src/lkql-adaptive_integers.ads
deleted file mode 100644
index 5100a7f3d..000000000
--- a/lkql/extensions/src/lkql-adaptive_integers.ads
+++ /dev/null
@@ -1,85 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Big_Integers; use LKQL.Big_Integers;
-
-package LKQL.Adaptive_Integers is
-
- -- This package provides an implementation for adaptive integers, that is,
- -- integers that adapt their internal representation depending on the kind
- -- of number they represent.
- --
- -- Integers between -Standard.Integer'First and Standard.Integer'Last are
- -- represented using a Standard.Integer value meaning that operating on
- -- this range of values is fast and has a low memory footprint.
- --
- -- Integers below or above the previous range are represented using
- -- LKQL.Big_Integers (as of now: GNATCOLL.GMP.Integers.Big_Integer).
- --
- -- Note:
- --
- -- - Operations between small ints that does not overflow always returns
- -- a small int.
- --
- -- - Operations in which one of the operand is a big int will always
- -- return a big int (even if the result could be held in a small int).
-
- type Adaptive_Integer is private;
-
- function Create (Value : Integer) return Adaptive_Integer;
- function Create (Value : String) return Adaptive_Integer;
-
- function Image (Int : Adaptive_Integer) return String;
-
- function "+" (Int : Adaptive_Integer) return Integer;
-
- function "=" (L, R : Adaptive_Integer) return Boolean;
- function "<" (L, R : Adaptive_Integer) return Boolean;
- function "<=" (L, R : Adaptive_Integer) return Boolean;
- function ">" (L, R : Adaptive_Integer) return Boolean;
- function ">=" (L, R : Adaptive_Integer) return Boolean;
-
- function "-" (L : Adaptive_Integer) return Adaptive_Integer;
-
- function "+" (L, R : Adaptive_Integer) return Adaptive_Integer;
- function "-" (L, R : Adaptive_Integer) return Adaptive_Integer;
- function "*" (L, R : Adaptive_Integer) return Adaptive_Integer;
- function "/" (L, R : Adaptive_Integer) return Adaptive_Integer;
-
- Zero : constant Adaptive_Integer;
-
-private
-
- type Internal_Kind is (Small, Big);
-
- type Adaptive_Integer (Kind : Internal_Kind := Small) is record
- case Kind is
- when Small =>
- Small_Value : Integer;
- when Big =>
- Big_Value : Big_Integer;
- end case;
- end record;
-
- Zero : constant Adaptive_Integer := (Small, 0);
-end LKQL.Adaptive_Integers;
diff --git a/lkql/extensions/src/lkql-big_integers.adb b/lkql/extensions/src/lkql-big_integers.adb
deleted file mode 100644
index 76c25629c..000000000
--- a/lkql/extensions/src/lkql-big_integers.adb
+++ /dev/null
@@ -1,233 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Deallocation;
-
-package body LKQL.Big_Integers is
- function Create (Value : GMP_Big_Integer) return Big_Integer;
-
- ------------
- -- Create --
- ------------
-
- function Create (Value : GMP_Big_Integer) return Big_Integer is
- begin
- return Res : constant Big_Integer :=
- (Ada.Finalization.Controlled with Value => new Big_Integer_Record'
- (Value => <>,
- Ref_Count => 1))
- do
- Res.Value.Value.Set (Value);
- end return;
- end Create;
-
- --------------------
- -- To_Big_Integer --
- --------------------
-
- function To_Big_Integer (Value : Integer) return Big_Integer is
- Res : GMP_Big_Integer;
- begin
- Res.Set (GNATCOLL.GMP.Long (Value));
- return Create (Res);
- end To_Big_Integer;
-
- ----------------
- -- To_Integer --
- ----------------
-
- function To_Integer (Value : Big_Integer) return Integer is
- (Integer'Value (To_String (Value)));
-
- -----------------
- -- From_String --
- -----------------
-
- function From_String (Value : String) return Big_Integer is
- (Create (GNATCOLL.GMP.Integers.Make (Value)));
-
- ---------------
- -- To_String --
- ---------------
-
- function To_String (Value : Big_Integer) return String is
- (GNATCOLL.GMP.Integers.Image (Value.Value.Value));
-
- generic
- with function Op (L, R : GMP_Big_Integer) return Boolean;
- function Rel_Op (L, R : Big_Integer) return Boolean;
- -- Generic implementation for binary operations over big integers
- -- returning a boolean.
-
- generic
- with function Op (L : GMP_Big_Integer) return GMP_Big_Integer;
- function Un_Op (L : Big_Integer) return Big_Integer;
- -- Generic implementation if unary operations over a big integer
- -- returning a big integer.
-
- generic
- with function Op (L, R : GMP_Big_Integer) return GMP_Big_Integer;
- function Bin_Op (L, R : Big_Integer) return Big_Integer;
- -- Generic implementation of binary operations over big integers
- -- returning a big integer.
-
- ------------
- -- Rel_Op --
- ------------
-
- function Rel_Op (L, R : Big_Integer) return Boolean is
- (Op (L.Value.Value, R.Value.Value));
-
- -----------
- -- Un_Op --
- -----------
-
- function Un_Op (L : Big_Integer) return Big_Integer is
- (Create (Op (L.Value.Value)));
-
- ------------
- -- Bin_Op --
- ------------
-
- function Bin_Op (L, R : Big_Integer) return Big_Integer is
- (Create (Op (L.Value.Value, R.Value.Value)));
-
- package Implementation is
- use GNATCOLL.GMP.Integers;
-
- function "=" is new Rel_Op ("=");
- function "<" is new Rel_Op ("<");
- function "<=" is new Rel_Op ("<=");
- function ">" is new Rel_Op (">");
- function ">=" is new Rel_Op (">=");
-
- function "-" is new Un_Op ("-");
-
- function "+" is new Bin_Op ("+");
- function "-" is new Bin_Op ("-");
- function "*" is new Bin_Op ("*");
- function "/" is new Bin_Op ("/");
- end Implementation;
-
- ---------
- -- "=" --
- ---------
-
- function "=" (L, R : Big_Integer) return Boolean
- renames Implementation."=";
-
- ---------
- -- "<" --
- ---------
-
- function "<" (L, R : Big_Integer) return Boolean
- renames Implementation."<";
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (L, R : Big_Integer) return Boolean
- renames Implementation."<=";
-
- ---------
- -- ">" --
- ---------
-
- function ">" (L, R : Big_Integer) return Boolean
- renames Implementation.">";
-
- ----------
- -- ">=" --
- ----------
-
- function ">=" (L, R : Big_Integer) return Boolean
- renames Implementation.">=";
-
- --------------
- -- In_Range --
- --------------
-
- function In_Range (Value, Lo, Hi : Big_Integer) return Boolean is
- (Lo <= Value and then Value <= Hi);
-
- ---------
- -- "-" --
- ---------
-
- function "-" (L : Big_Integer) return Big_Integer
- renames Implementation."-";
-
- ---------
- -- "+" --
- ---------
-
- function "+" (L, R : Big_Integer) return Big_Integer
- renames Implementation."+";
-
- ---------
- -- "-" --
- ---------
-
- function "-" (L, R : Big_Integer) return Big_Integer
- renames Implementation."-";
-
- ---------
- -- "*" --
- ---------
-
- function "*" (L, R : Big_Integer) return Big_Integer
- renames Implementation."*";
-
- ---------
- -- "/" --
- ---------
-
- function "/" (L, R : Big_Integer) return Big_Integer
- renames Implementation."/";
-
- ----------
- -- Free --
- ----------
-
- procedure Free is new Ada.Unchecked_Deallocation
- (Big_Integer_Record, Big_Integer_Record_Access);
- -- Free a big integer record
-
- overriding procedure Adjust (X : in out Big_Integer) is
- begin
- if X.Value /= null then
- X.Value.Ref_Count := X.Value.Ref_Count + 1;
- end if;
- end Adjust;
-
- overriding procedure Finalize (X : in out Big_Integer) is
- begin
- if X.Value /= null then
- X.Value.Ref_Count := X.Value.Ref_Count - 1;
- if X.Value.Ref_Count = 0 then
- Free (X.Value);
- end if;
- end if;
- end Finalize;
-end LKQL.Big_Integers;
diff --git a/lkql/extensions/src/lkql-big_integers.ads b/lkql/extensions/src/lkql-big_integers.ads
deleted file mode 100644
index bffead871..000000000
--- a/lkql/extensions/src/lkql-big_integers.ads
+++ /dev/null
@@ -1,76 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Finalization;
-
-with GNATCOLL.GMP.Integers;
-use GNATCOLL;
-
-package LKQL.Big_Integers is
- -- This package follows the exact same API as the Ada202x
- -- `Ada.Numerics.Big_Numbers.Big_Integers` package. Once that package is
- -- available, this package can be completely removed, and the transition
- -- can be done simply and safely by replacing all occurrences of
- -- `LKQL.Integers` by `Ada.Numerics.Big_Numbers.Big_Integers`.
-
- type Big_Integer is private;
-
- function To_Big_Integer (Value : Integer) return Big_Integer;
- function To_Integer (Value : Big_Integer) return Integer;
-
- function From_String (Value : String) return Big_Integer;
- function To_String (Value : Big_Integer) return String;
-
- function "=" (L, R : Big_Integer) return Boolean;
- function "<" (L, R : Big_Integer) return Boolean;
- function "<=" (L, R : Big_Integer) return Boolean;
- function ">" (L, R : Big_Integer) return Boolean;
- function ">=" (L, R : Big_Integer) return Boolean;
-
- function In_Range (Value, Lo, Hi : Big_Integer) return Boolean;
-
- function "-" (L : Big_Integer) return Big_Integer;
-
- function "+" (L, R : Big_Integer) return Big_Integer;
- function "-" (L, R : Big_Integer) return Big_Integer;
- function "*" (L, R : Big_Integer) return Big_Integer;
- function "/" (L, R : Big_Integer) return Big_Integer;
-
-private
-
- subtype GMP_Big_Integer is GMP.Integers.Big_Integer;
-
- type Big_Integer_Record is limited record
- Value : GMP_Big_Integer;
- Ref_Count : Natural;
- end record;
-
- type Big_Integer_Record_Access is access Big_Integer_Record;
-
- type Big_Integer is new Ada.Finalization.Controlled with record
- Value : Big_Integer_Record_Access := null;
- end record;
-
- overriding procedure Adjust (X : in out Big_Integer);
- overriding procedure Finalize (X : in out Big_Integer);
-end LKQL.Big_Integers;
diff --git a/lkql/extensions/src/lkql-builtin_functions.adb b/lkql/extensions/src/lkql-builtin_functions.adb
deleted file mode 100644
index c5649ab75..000000000
--- a/lkql/extensions/src/lkql-builtin_functions.adb
+++ /dev/null
@@ -1,1610 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Characters.Conversions; use Ada.Characters.Conversions;
-with Ada.Wide_Wide_Characters.Handling;
-with Ada.Containers.Hashed_Sets;
-with Ada.Directories;
-with Ada.Finalization;
-with Ada.Strings.Wide_Wide_Fixed;
-with Ada.Unchecked_Deallocation;
-with Ada.Wide_Wide_Text_IO;
-
-with GNAT.Array_Split;
-with GNAT.Regpat;
-
-with Liblkqllang.Common; use Liblkqllang.Common;
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-with Langkit_Support.Slocs; use Langkit_Support.Slocs;
-
-with LKQL.Adaptive_Integers; use LKQL.Adaptive_Integers;
-with LKQL.Evaluation; use LKQL.Evaluation;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with LKQL.String_Utils; use LKQL.String_Utils;
-with LKQL.Errors; use LKQL.Errors;
-with LKQL.Error_Handling; use LKQL.Error_Handling;
-
-package body LKQL.Builtin_Functions is
-
- function Is_Upper (C : Wide_Wide_Character) return Boolean renames
- Ada.Wide_Wide_Characters.Handling.Is_Upper;
- function Is_Lower (C : Wide_Wide_Character) return Boolean renames
- Ada.Wide_Wide_Characters.Handling.Is_Lower;
-
- function Get_Doc (Ctx : Eval_Context; Obj : Primitive) return Text_Type;
-
- function Eval_Print
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_To_List
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Dump
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Node_Kind
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Image
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Children_Count
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Text
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Starts_With
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Ends_With
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Is_Lower_Case
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Is_Upper_Case
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Is_Mixed_Case
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_To_Lower_Case
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Concat
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Split
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Substring
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Base_Name
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Doc
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Profile
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Get_Symbols
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Get_Builtin_Methods_Info
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Help
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Token_Next
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Token_Previous
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Tokens
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Same_Tokens
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Units
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Unit_Tokens
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Token_Is_Equivalent
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Token_Is_Trivia
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Token_Text
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Token_Kind
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Find
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Find_Pattern_Or_String
- (Ctx : Eval_Context;
- Str : Text_Type;
- To_Find : Primitive) return Natural;
- -- Find ``To_Find`` in ``Str``. ``To_Find`` can be either a string or a
- -- regex value. Return position of match or 0 if no match.
-
- function Eval_Contains
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Create
- (Name : Text_Type;
- Params : Builtin_Function_Profile;
- Fn_Access : Native_Function_Access;
- Doc : Text_Type;
- Only_Dot_Calls : Boolean := False) return Builtin_Function;
- -- Create a builtin function given a name, a description of its
- -- parameters and an access to the native code that implements it.
-
- function Param
- (Name : Text_Type;
- Expected_Kind : Base_Primitive_Kind := No_Kind)
- return Builtin_Param_Description;
- -- Create a builtin parameter description given its name and its expected
- -- kind. The expected kind can be "No_Kind" if no particular kind is
- -- expected. This parameter will not have a default value.
-
- function Param
- (Name : Text_Type;
- Expected_Kind : Base_Primitive_Kind;
- Default_Value : Primitive)
- return Builtin_Param_Description;
- -- Create a builtin parameter description given its name, expected
- -- kind and default value. The expected kind can be "No_Kind" if no
- -- particular kind is expected.
-
- function Is_Eq (L, R : Lk_Token) return Boolean;
- -- Returns whether two tokens are equivalent
-
- ------------
- -- Create --
- ------------
-
- function Create
- (Name : Text_Type;
- Params : Builtin_Function_Profile;
- Fn_Access : Native_Function_Access;
- Doc : Text_Type;
- Only_Dot_Calls : Boolean := False) return Builtin_Function
- is
- begin
- return new Builtin_Function_Description'
- (N => Params'Length,
- Name => To_Unbounded_Text (Name),
- Params => Params,
- Fn_Access => Fn_Access,
- Doc => To_Unbounded_Text (Doc),
- Only_Dot_Calls => Only_Dot_Calls);
- end Create;
-
- -----------
- -- Param --
- -----------
-
- function Param
- (Name : Text_Type;
- Expected_Kind : Base_Primitive_Kind := No_Kind)
- return Builtin_Param_Description
- is
- begin
- return Builtin_Param_Description'
- (Name => To_Unbounded_Text (Name),
- Expected_Kind => Expected_Kind,
- Default_Value => Primitive_Options.None);
- end Param;
-
- -----------
- -- Param --
- -----------
-
- function Param
- (Name : Text_Type;
- Expected_Kind : Base_Primitive_Kind;
- Default_Value : Primitive)
- return Builtin_Param_Description
- is
- begin
- return Builtin_Param_Description'
- (Name => To_Unbounded_Text (Name),
- Expected_Kind => Expected_Kind,
- Default_Value => Primitive_Options.To_Option (Default_Value));
- end Param;
-
- ----------------
- -- Eval_Print --
- ----------------
-
- function Eval_Print
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Ctx);
- begin
- Display (Args (1), Bool_Val (Args (2)));
- return Make_Unit_Primitive;
- end Eval_Print;
-
- ------------------
- -- Eval_To_List --
- ------------------
-
- function Eval_To_List
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Result : constant Primitive := Make_Empty_List (Ctx.Pool);
- Lst : constant Primitive := Args (1);
- Els : Primitive_Vector_Access;
- begin
- case Lst.Kind is
- when Kind_List | Kind_Iterator =>
- Els := Elements (Lst);
- when Kind_Selector_List =>
- Els := To_List (Lst.Selector_List_Val, Ctx.Pool)
- .List_Val.Elements'Access;
- when others =>
- Raise_Invalid_Type
- (Ctx, L.No_Lkql_Node, "iterable", Lst);
- end case;
-
- for El of Els.all loop
- Append (Result, El);
- end loop;
- return Result;
- end Eval_To_List;
-
- ---------------
- -- Eval_Dump --
- ---------------
-
- function Eval_Dump
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Ctx);
- begin
- Args (1).Node_Val.Print;
- return Make_Unit_Primitive;
- end Eval_Dump;
-
- --------------------
- -- Eval_Node_Kind --
- --------------------
-
- function Eval_Node_Kind
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- begin
- return To_Primitive
- (LKN.Format_Name
- (LKI.Node_Type_Name (LKI.Type_Of (Args (1).Node_Val)),
- LKN.Camel),
- Ctx.Pool);
- end Eval_Node_Kind;
-
- ----------------
- -- Eval_Image --
- ----------------
-
- function Eval_Image
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- begin
- return To_Primitive (To_Text (To_Unbounded_Text (Args (1))), Ctx.Pool);
- end Eval_Image;
-
- -------------------------
- -- Eval_Children_Count --
- -------------------------
-
- function Eval_Children_Count
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Node : constant Lk_Node := Node_Val (Args (1));
- begin
- return To_Primitive
- ((if Node.Is_Null then 0 else Node.Children_Count), Ctx.Pool);
- end Eval_Children_Count;
-
- ---------------
- -- Eval_Text --
- ---------------
-
- function Eval_Text
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Node : constant Lk_Node := Node_Val (Args (1));
- begin
- return To_Primitive
- ((if Node.Is_Null then "" else Node.Text), Ctx.Pool);
- end Eval_Text;
-
- -----------------
- -- Starts_With --
- -----------------
-
- function Eval_Starts_With
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Ctx);
-
- Str : constant Text_Type := Str_Val (Args (1));
- Prefix : constant Text_Type := Str_Val (Args (2));
- Len : constant Natural := Prefix'Length;
- begin
- return To_Primitive
- (Str'Length >= Len
- and then Str (Str'First .. Str'First + Len - 1) = Prefix);
- end Eval_Starts_With;
-
- ---------------
- -- Ends_With --
- ---------------
-
- function Eval_Ends_With
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Ctx);
-
- Str : constant Text_Type := Str_Val (Args (1));
- Suffix : constant Text_Type := Str_Val (Args (2));
-
- Str_Len : constant Natural := Str'Length;
- Suffix_Len : constant Natural := Suffix'Length;
- begin
- return To_Primitive
- (Str_Len >= Suffix_Len
- and then Str (Str'Last - Suffix_Len + 1 .. Str'Last) = Suffix);
- end Eval_Ends_With;
-
- ------------------------
- -- Eval_Is_Lower_Case --
- ------------------------
-
- function Eval_Is_Lower_Case
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Ctx);
-
- Str : constant Text_Type := Str_Val (Args (1));
- begin
- for C of Str loop
- if Is_Upper (C) then
- return To_Primitive (False);
- end if;
- end loop;
- return To_Primitive (True);
- end Eval_Is_Lower_Case;
-
- ------------------------
- -- Eval_Is_Upper_Case --
- ------------------------
-
- function Eval_Is_Upper_Case
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Ctx);
-
- Str : constant Text_Type := Str_Val (Args (1));
- begin
- for C of Str loop
- if Is_Lower (C) then
- return To_Primitive (False);
- end if;
- end loop;
- return To_Primitive (True);
- end Eval_Is_Upper_Case;
-
- ------------------------
- -- Eval_Is_Mixed_Case --
- ------------------------
-
- function Eval_Is_Mixed_Case
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Ctx);
-
- Str : constant Text_Type := Str_Val (Args (1));
-
- Must_Be_Upper_Case : Boolean := True;
- begin
- for C of Str loop
- if Must_Be_Upper_Case then
- if Is_Lower (C) then
- return To_Primitive (False);
- else
- Must_Be_Upper_Case := False;
- end if;
- elsif Is_Upper (C) then
- return To_Primitive (False);
- elsif C = '_' then
- Must_Be_Upper_Case := True;
- end if;
- end loop;
- return To_Primitive (True);
- end Eval_Is_Mixed_Case;
-
- -----------------
- -- Eval_Concat --
- -----------------
-
- function Eval_Concat
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Arg : constant Primitive_List_Access := List_Val (Args (1));
- begin
- if not Arg.Elements.Is_Empty then
- declare
- First_Item : constant Primitive := Get (Arg, 1);
- begin
- case Kind (First_Item) is
- -- When the first item is a string
- when Kind_Str =>
- declare
- Res : Primitive := To_Primitive (To_Text (""), Ctx.Pool);
- begin
- for Item of Arg.Elements loop
- Check_Kind (Kind_Str, Item);
- Res := To_Primitive
- (Str_Val (Res) & Str_Val (Item),
- Ctx.Pool);
- end loop;
- return Res;
- end;
-
- -- When the first item is a list
- when Kind_List =>
- declare
- Res : constant Primitive := Make_Empty_List (Ctx.Pool);
- begin
- for Item of Arg.Elements loop
- Check_Kind (Kind_List, Item);
- for El of Item.List_Val.Elements loop
- Res.List_Val.Elements.Append (El);
- end loop;
- end loop;
- return Res;
- end;
-
- -- Other raise en error
- when others =>
- raise Unsupported_Error with
- "Wrong kind " & Kind_Name (First_Item);
- end case;
- end;
- else
- return Make_Empty_List (Ctx.Pool);
- end if;
- end Eval_Concat;
-
- -------------------
- -- To_Lower_Case --
- -------------------
-
- function Eval_To_Lower_Case
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Str : constant Text_Type := Str_Val (Args (1));
- begin
- return To_Primitive (To_Lower (Str), Ctx.Pool);
- end Eval_To_Lower_Case;
-
- -------------------
- -- Eval_Contains --
- -------------------
-
- function Eval_Contains
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- begin
- return To_Primitive
- (Find_Pattern_Or_String (Ctx, Str_Val (Args (1)), Args (2)) > 0);
- end Eval_Contains;
-
- ----------------
- -- Eval_Split --
- ----------------
-
- function Eval_Split
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Str : constant Text_Type := Str_Val (Args (1));
- Separator : constant Text_Type := Str_Val (Args (2));
- Ret : constant Primitive := Make_Empty_List (Ctx.Pool);
-
- function To_Set (Element : Wide_Wide_String) return Wide_Wide_Character
- is (Element (Element'First));
-
- function Is_In
- (Item : Wide_Wide_Character; Set : Wide_Wide_Character)
- return Boolean is (Item = Set);
-
- package String_Split is new GNAT.Array_Split
- (Element => Wide_Wide_Character,
- Element_Sequence => Wide_Wide_String,
- Element_Set => Wide_Wide_Character,
- To_Set => To_Set,
- Is_In => Is_In);
-
- begin
- for Word of String_Split.Create (Str, Separator (Separator'First)) loop
- Ret.List_Val.Elements.Append (To_Primitive (Word, Ctx.Pool));
- end loop;
-
- return Ret;
- end Eval_Split;
-
- --------------------
- -- Eval_Substring --
- --------------------
-
- function Eval_Substring
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Str : constant Text_Type := Str_Val (Args (1));
- From : constant Integer := Str'First + (+Int_Val (Args (2))) - 1;
- To : constant Integer := Str'First + (+Int_Val (Args (3))) - 1;
- begin
- return To_Primitive (Text_Type'(Str (From .. To)), Ctx.Pool);
- end Eval_Substring;
-
- --------------------
- -- Eval_Base_Name --
- --------------------
-
- function Eval_Base_Name
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Str : constant Text_Type := Str_Val (Args (1));
- begin
- return To_Primitive
- (To_Text (Ada.Directories.Simple_Name (Image (Str))),
- Ctx.Pool);
- exception
- when Ada.Directories.Name_Error =>
- return To_Primitive ("", Ctx.Pool);
- end Eval_Base_Name;
-
- -------------
- -- Get_Doc --
- -------------
-
- function Get_Doc (Ctx : Eval_Context; Obj : Primitive) return Text_Type is
- begin
- case Kind (Obj) is
- when Kind_Builtin_Function =>
- return To_Text (Obj.Builtin_Fn.Doc);
- when Kind_Function =>
- declare
- Doc_Obj : constant L.Base_String_Literal :=
- Obj.Fun_Node.P_Doc;
- begin
- return
- (if Doc_Obj.Is_Null
- then ""
- else Str_Val (Eval (Ctx, Doc_Obj)));
- end;
- when Kind_Selector =>
- declare
- Doc : constant L.Base_String_Literal :=
- Obj.Sel_Node.P_Doc;
- begin
- if not Doc.Is_Null then
- return Str_Val (Eval (Ctx, Doc));
- end if;
- return "";
- end;
- when Kind_Namespace =>
- if Obj.Module.Children_Count = 0 then
- return "";
- end if;
-
- declare
- First_Child : constant L.Lkql_Node :=
- Obj.Module.Child (1);
- begin
- if First_Child.Kind in LCO.Lkql_Base_String_Literal then
- return Str_Val (Eval (Ctx, First_Child));
- end if;
- return "";
- end;
- when others =>
- return "";
- end case;
- end Get_Doc;
-
- --------------
- -- Eval_Doc --
- --------------
-
- function Eval_Doc
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive is
- begin
- return To_Primitive (Get_Doc (Ctx, Args (1)), Ctx.Pool);
- end Eval_Doc;
-
- ------------------
- -- Eval_Profile --
- ------------------
-
- function Eval_Profile
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- begin
- return To_Primitive (Profile (Args (1)), Ctx.Pool);
- end Eval_Profile;
-
- ---------------
- -- Eval_Help --
- ---------------
-
- function Eval_Help
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Obj : constant Primitive := Args (1);
- Doc : constant Text_Type := Get_Doc (Ctx, Obj);
- begin
- Ada.Wide_Wide_Text_IO.Put_Line (Profile (Obj));
- Ada.Wide_Wide_Text_IO.New_Line;
- Ada.Wide_Wide_Text_IO.Set_Col (4);
- Ada.Wide_Wide_Text_IO.Put_Line (Doc);
- Ada.Wide_Wide_Text_IO.Set_Col (1);
-
- return Make_Unit_Primitive;
- end Eval_Help;
-
- ----------------------------
- -- Eval_Get_Local_Symbols --
- ----------------------------
-
- function Eval_Get_Symbols
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- procedure Get_Symbols_In_Frame
- (C : Eval_Contexts.Environment_Access; Recurse : Boolean);
-
- S : Symbol_Set;
-
- procedure Get_Symbols_In_Frame
- (C : Eval_Contexts.Environment_Access; Recurse : Boolean)
- is
- begin
- if C = null then
- return;
- end if;
- for I in Get_Env_Map (C).Iterate loop
- S.Include (String_Value_Maps.Key (I));
- end loop;
-
- if Recurse then
- Get_Symbols_In_Frame (Get_Parent (C), True);
- end if;
- end Get_Symbols_In_Frame;
-
- Pkg : constant Primitive := Args (1);
- Ret : constant Primitive := Make_Empty_List (Ctx.Pool);
- begin
-
- if Booleanize (Pkg) then
- Get_Symbols_In_Frame
- (Eval_Contexts.Environment_Access (Pkg.Namespace),
- Recurse => False);
- else
- Get_Symbols_In_Frame (Ctx.Frames, Recurse => True);
- end if;
-
- for El of S loop
- Ret.List_Val.Elements.Append (To_Primitive (El.all, Ctx.Pool));
- end loop;
- return Ret;
-
- end Eval_Get_Symbols;
-
- -----------------------------------
- -- Eval_Get_Builtin_Methods_Info --
- -----------------------------------
-
- function Eval_Get_Builtin_Methods_Info
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Args);
- Ret : constant Primitive := Make_Empty_Object (Ctx.Pool);
- begin
- for Method in Get_Builtin_Methods (Ctx.Kernel).Iterate loop
- declare
- Sub_Obj : constant Primitive := Make_Empty_Object (Ctx.Pool);
- Builtin_Func : constant Builtin_Function :=
- Builtin_Methods_Maps.Element (Method);
- begin
- Ret.Obj_Assocs.Elements.Include
- (Builtin_Methods_Maps.Key (Method).Name,
- Sub_Obj);
- Sub_Obj.Obj_Assocs.Elements.Include
- (Ctx.Symbol ("doc"),
- To_Primitive (To_Text (Builtin_Func.Doc), Ctx.Pool));
- Sub_Obj.Obj_Assocs.Elements.Include
- (Ctx.Symbol ("name"),
- To_Primitive (To_Text (Builtin_Func.Name), Ctx.Pool));
-
- declare
- Params : constant Primitive := Make_Empty_List (Ctx.Pool);
- begin
- for Param of Builtin_Func.Params loop
- declare
- Param_Info : constant Primitive :=
- Make_Empty_Tuple (Ctx.Pool);
- begin
- Param_Info.List_Val.Elements.Append
- (To_Primitive (To_Text (Param.Name), Ctx.Pool));
- Param_Info.List_Val.Elements.Append
- (To_Primitive
- (Param.Expected_Kind'Wide_Wide_Image, Ctx.Pool));
- Params.List_Val.Elements.Append (Param_Info);
- end;
- end loop;
-
- Sub_Obj.Obj_Assocs.Elements.Include
- (Ctx.Symbol ("params"), Params);
- end;
- end;
- end loop;
- return Ret;
- end Eval_Get_Builtin_Methods_Info;
-
- ---------------------
- -- Eval_Token_Next --
- ---------------------
-
- function Eval_Token_Next
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Exclude_Trivia : constant Boolean := Args (2).Bool_Val;
- Next_Token : constant Lk_Token := Args (1).Token_Val.Next
- (Exclude_Trivia => Exclude_Trivia);
- begin
- return To_Primitive (Next_Token, Ctx.Pool);
- end Eval_Token_Next;
-
- -------------------------
- -- Eval_Token_Previous --
- -------------------------
-
- function Eval_Token_Previous
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Exclude_Trivia : constant Boolean := Args (2).Bool_Val;
- Previous_Token : constant Lk_Token :=
- Args (1).Token_Val.Previous (Exclude_Trivia => Exclude_Trivia);
- begin
- return To_Primitive (Previous_Token, Ctx.Pool);
- end Eval_Token_Previous;
-
- ----------------------
- -- Eval_Unit_Tokens --
- ----------------------
-
- function Eval_Unit_Tokens
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Tokens : Primitive_Vectors.Vector;
- Unit : constant Lk_Unit :=
- Args (1).Analysis_Unit_Val;
- Token : Lk_Token := Unit.First_Token;
- Last_Token : constant Lk_Token := Unit.Last_Token;
- begin
- while Token /= Last_Token loop
- Tokens.Append (To_Primitive (Token, Ctx.Pool));
- Token := Token.Next;
- end loop;
-
- declare
- Iter : Primitive_Vec_Iters.Vec_Iterator :=
- Primitive_Vec_Iters.To_Iterator (Tokens);
- Ret : constant Primitive := To_Primitive (Iter, Ctx.Pool);
- begin
- Iter.Release;
- return Ret;
- end;
- end Eval_Unit_Tokens;
-
- -----------------
- -- Eval_Tokens --
- -----------------
-
- function Eval_Tokens
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- Tokens : Primitive_Vectors.Vector;
- Node : constant Lk_Node := Args (1).Node_Val;
- Token : Lk_Token := Node.Token_Start;
- Last_Token : constant Lk_Token := Node.Token_End;
- begin
- if Node.Sloc_Range.Start_Column /= Node.Sloc_Range.End_Column then
- while Token /= Last_Token loop
- Tokens.Append (To_Primitive (Token, Ctx.Pool));
- Token := Token.Next;
- end loop;
- Tokens.Append (To_Primitive (Token, Ctx.Pool));
- end if;
-
- return To_Primitive
- (Primitive_Iter (Primitive_Vec_Iters.To_Iterator (Tokens)), Ctx.Pool);
- end Eval_Tokens;
-
- -----------
- -- Is_Eq --
- -----------
-
- function Is_Eq (L, R : Lk_Token) return Boolean is
- use Langkit_Support.Generic_API;
- begin
- return L.Kind = R.Kind
- and then
- (if LKN.Format_Name (Token_Kind_Name (L.Kind), LKN.Lower)
- = "identifier"
- then To_Lower (L.Text) = To_Lower (R.Text) else L.Text = R.Text);
- end Is_Eq;
-
- ----------------------
- -- Eval_Same_Tokens --
- ----------------------
-
- function Eval_Same_Tokens
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Ctx);
-
- L : constant Lk_Node := Args (1).Node_Val;
- R : constant Lk_Node := Args (2).Node_Val;
- L_Token : Lk_Token := L.Token_Start;
- L_Last_Token : constant Lk_Token := L.Token_End;
- R_Token : Lk_Token := R.Token_Start;
- R_Last_Token : constant Lk_Token := R.Token_End;
-
- procedure Next_Non_Trivia (Token : in out Lk_Token);
- -- Move Token to the next non trivia token
-
- ---------------------
- -- Next_Non_Trivia --
- ---------------------
-
- procedure Next_Non_Trivia (Token : in out Lk_Token) is
- begin
- while Token.Is_Trivia loop
- Token := Token.Next;
- end loop;
- end Next_Non_Trivia;
-
- begin
- loop
- Next_Non_Trivia (L_Token);
- Next_Non_Trivia (R_Token);
-
- if not Is_Eq (L_Token, R_Token) then
- return To_Primitive (False);
- end if;
-
- if L_Token = L_Last_Token then
- return To_Primitive (R_Token = R_Last_Token);
- elsif R_Token = R_Last_Token then
- return To_Primitive (False);
- end if;
-
- L_Token := L_Token.Next;
- R_Token := R_Token.Next;
- end loop;
- end Eval_Same_Tokens;
-
- ----------------
- -- Eval_Units --
- ----------------
-
- function Eval_Units
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Args);
- Units : Primitive_Vectors.Vector;
- begin
- for Root of Ctx.AST_Roots.all loop
- Units.Append (To_Primitive (Root.Unit, Ctx.Pool));
- end loop;
-
- return To_Primitive
- (Primitive_Iter (Primitive_Vec_Iters.To_Iterator (Units)), Ctx.Pool);
- end Eval_Units;
-
- ------------------------------
- -- Eval_Token_Is_Equivalent --
- ------------------------------
-
- function Eval_Token_Is_Equivalent
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Ctx);
- begin
- return To_Primitive (Is_Eq (Args (1).Token_Val, Args (2).Token_Val));
- end Eval_Token_Is_Equivalent;
-
- --------------------------
- -- Eval_Token_Is_Trivia --
- --------------------------
-
- function Eval_Token_Is_Trivia
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- pragma Unreferenced (Ctx);
- begin
- return To_Primitive (Args (1).Token_Val.Is_Trivia);
- end Eval_Token_Is_Trivia;
-
- ---------------------
- -- Eval_Token_Text --
- ---------------------
-
- function Eval_Token_Text
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- begin
- return To_Primitive (Args (1).Token_Val.Text, Ctx.Pool);
- end Eval_Token_Text;
-
- ---------------------
- -- Eval_Token_Kind --
- ---------------------
-
- function Eval_Token_Kind
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- use Langkit_Support.Generic_API;
- begin
- if Args (1).Token_Val.Is_Null then
- return To_Primitive ("no_token", Ctx.Pool);
- else
- return To_Primitive
- (LKN.Format_Name
- (Token_Kind_Name (Args (1).Token_Val.Kind), LKN.Lower), Ctx.Pool);
- end if;
- end Eval_Token_Kind;
-
- ---------------------
- -- Eval_Start_Line --
- ---------------------
-
- function Eval_Start_Line
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- (To_Primitive
- (Integer (Args (1)
- .Token_Val.Sloc_Range.Start_Line), Ctx.Pool));
-
- ---------------------
- -- Eval_Token_Unit --
- ---------------------
-
- function Eval_Token_Unit
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- (To_Primitive (Args (1).Token_Val.Unit, Ctx.Pool));
-
- -------------------
- -- Eval_End_Line --
- -------------------
-
- function Eval_End_Line
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- (To_Primitive
- (Integer (Args (1)
- .Token_Val.Sloc_Range.End_Line), Ctx.Pool));
-
- --------------------
- -- Eval_Start_Col --
- --------------------
-
- function Eval_Start_Col
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- (To_Primitive
- (Integer (Args (1)
- .Token_Val.Sloc_Range.Start_Column), Ctx.Pool));
-
- ------------------
- -- Eval_End_Col --
- ------------------
-
- function Eval_End_Col
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- (To_Primitive
- (Integer (Args (1)
- .Token_Val.Sloc_Range.End_Column), Ctx.Pool));
-
- --------------------
- -- Eval_Unit_Text --
- --------------------
-
- function Eval_Unit_Text
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- (To_Primitive
- (Args (1).Analysis_Unit_Val.Text, Ctx.Pool));
-
- --------------------
- -- Eval_Unit_Root --
- --------------------
-
- function Eval_Unit_Name
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- (To_Primitive
- (To_Text (Args (1).Analysis_Unit_Val.Filename), Ctx.Pool));
-
- --------------------
- -- Eval_Unit_Root --
- --------------------
-
- function Eval_Unit_Root
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- (To_Primitive (Args (1).Analysis_Unit_Val.Root, Ctx.Pool));
-
- --------------------
- -- Eval_Reduce --
- --------------------
-
- function Eval_Reduce
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive;
-
- function Eval_Reduce
- (Ctx : Eval_Context; Args : Primitive_Array) return Primitive
- is
- List : constant Primitive_Vector_Access := Elements (Args (1));
- Fn : constant Primitive := Args (2);
- Init_Val : constant Primitive := Args (3);
- begin
- case Fn.Kind is
- when Kind_Function =>
- declare
- D : L.Base_Function;
- First_Arg_Name, Second_Arg_Name : Symbol_Type;
- Env : constant LKQL.Primitives.Environment_Access :=
- Fn.Frame;
- Eval_Ctx : constant Eval_Context :=
- Eval_Context'
- (Ctx.Kernel, Eval_Contexts.Environment_Access (Env));
-
- function Eval_Call
- (Accumulator_Value : Primitive;
- Current_Value : Primitive) return Primitive;
-
- function Eval_Call
- (Accumulator_Value : Primitive;
- Current_Value : Primitive) return Primitive
- is
- Args_Bindings : Environment_Map;
- begin
- Args_Bindings.Insert (First_Arg_Name, Accumulator_Value);
- Args_Bindings.Insert (Second_Arg_Name, Current_Value);
- return Eval
- (Eval_Ctx, D.F_Body_Expr, Local_Bindings => Args_Bindings);
- end Eval_Call;
-
- begin
- D := Fn.Fun_Node;
-
- if D.F_Parameters.Children_Count /= 2 then
- Raise_And_Record_Error
- (Ctx,
- Make_Eval_Error
- (L.No_Lkql_Node,
- "Function passed to reduce should have arity of two"));
- end if;
-
- First_Arg_Name :=
- Symbol (D.F_Parameters.Child (1).As_Parameter_Decl.P_Identifier);
-
- Second_Arg_Name :=
- Symbol (D.F_Parameters.Child (2).As_Parameter_Decl.P_Identifier);
-
- declare
- Accum : Primitive := Init_Val;
- begin
- for El of List.all loop
- Accum := Eval_Call (Accum, El);
- end loop;
- return Accum;
- end;
- end;
-
- when others =>
- Raise_Invalid_Type
- (Ctx, L.No_Lkql_Node, "function", Fn);
- end case;
- end Eval_Reduce;
-
- package Primitive_Sets is new Ada.Containers.Hashed_Sets
- (Primitive, Hash, Equals, Equals);
-
- -----------------
- -- Eval_Unique --
- -----------------
-
- function Eval_Unique
- (Ctx : Eval_Context;
- Args : Primitive_Array) return Primitive;
-
- function Eval_Unique
- (Ctx : Eval_Context;
- Args : Primitive_Array) return Primitive
- is
- S : Primitive_Sets.Set;
- List : constant Primitive_Vector_Access := Elements (Args (1));
- begin
- for El of List.all loop
- S.Include (El);
- end loop;
-
- declare
- Ret : constant Primitive :=
- LKQL.Primitives.Make_Empty_List (Ctx.Pool);
- begin
- for El of S loop
- Ret.List_Val.Elements.Append (El);
- end loop;
- return Ret;
- end;
- end Eval_Unique;
-
- -------------------------
- -- Eval_Create_Pattern --
- -------------------------
-
- function Eval_Create_Pattern
- (Ctx : Eval_Context;
- Args : Primitive_Array) return Primitive
- is
- (Make_Regex
- (GNAT.Regpat.Compile
- (To_String (Str_Val (Args (1))),
- (if Bool_Val (Args (2))
- then GNAT.Regpat.No_Flags else GNAT.Regpat.Case_Insensitive)),
- Ctx.Pool));
-
- ----------------
- -- Eval_Find --
- ----------------
-
- function Eval_Find
- (Ctx : Eval_Context;
- Args : Primitive_Array) return Primitive
- is
- begin
- return To_Primitive
- (Find_Pattern_Or_String (Ctx, Str_Val (Args (1)), Args (2)), Ctx.Pool);
- end Eval_Find;
-
- function Find_Pattern_Or_String
- (Ctx : Eval_Context;
- Str : Text_Type;
- To_Find : Primitive) return Natural
- is
- use Ada.Strings.Wide_Wide_Fixed;
- begin
- if To_Find.Kind = Kind_Regex then
- return GNAT.Regpat.Match (To_Find.Regex_Val.all, Image (Str));
- elsif To_Find.Kind = Kind_Str then
- return Index (Str, Str_Val (To_Find));
- else
- Raise_Invalid_Type
- (Ctx, L.No_Lkql_Node, "string or pattern", To_Find);
- end if;
- end Find_Pattern_Or_String;
-
- -----------------------
- -- Builtin_Functions --
- -----------------------
-
- Builtin_Functions : constant Builtin_Function_Array :=
- (Create
- ("print",
- (Param ("val"),
- Param ("new_line", Kind_Bool, To_Primitive (True))),
- Eval_Print'Access,
- "Built-in print function. Prints whatever is passed as an argument"),
-
- Create
- ("reduce",
- (Param ("indexable"), Param ("fn"), Param ("init")),
- Eval_Reduce'Access,
- "Given a collection, a reduction function, and an initial value" &
- " reduce the result"),
-
- Create
- ("unique",
- (1 => Param ("indexable")),
- Eval_Unique'Access,
- ""),
-
- Create
- ("img",
- (1 => Param ("val")),
- Eval_Image'Access,
- "Return a string representation of an object"),
-
- Create
- ("dump",
- (1 => Param ("node", Kind_Node)),
- Eval_Dump'Access,
- "Given an ast node, return a structured dump of the subtree",
- Only_Dot_Calls => True),
-
- Create
- ("kind",
- (1 => Param ("node", Kind_Node)),
- Eval_Node_Kind'Access,
- "Return the kind of this node, as a string",
- Only_Dot_Calls => True),
-
- Create
- ("text",
- (1 => Param ("node", Kind_Node)),
- Eval_Text'Access,
- "Given an ast node, return its text",
- Only_Dot_Calls => True),
-
- Create
- ("to_list",
- (1 => Param ("it")),
- Eval_To_List'Access,
- "Transform an iterator into a list",
- Only_Dot_Calls => True),
-
- Create
- ("children_count",
- (1 => Param ("node", Kind_Node)),
- Eval_Children_Count'Access,
- "Given a node, return the count of its children",
- Only_Dot_Calls => True),
-
- Create
- ("tokens",
- (1 => Param ("node", Kind_Node)),
- Eval_Tokens'Access,
- "Given a node, return an iterator on its tokens",
- Only_Dot_Calls => True),
-
- Create
- ("same_tokens",
- (1 => Param ("self", Kind_Node),
- 2 => Param ("node", Kind_Node)),
- Eval_Same_Tokens'Access,
- "Return whether two nodes have the same tokens, ignoring trivias",
- Only_Dot_Calls => True),
-
- -- Token builtins
-
- Create
- ("text",
- (1 => Param ("token", Kind_Token)),
- Eval_Token_Text'Access,
- "Return the text for this token",
- Only_Dot_Calls => True),
-
- Create
- ("kind",
- (1 => Param ("token", Kind_Token)),
- Eval_Token_Kind'Access,
- "Return the kind for this token, as a string",
- Only_Dot_Calls => True),
-
- Create
- ("is_equivalent",
- (1 => Param ("self", Kind_Token),
- 2 => Param ("token", Kind_Token)),
- Eval_Token_Is_Equivalent'Access,
- "Return whether two tokens are structurally equivalent",
- Only_Dot_Calls => True),
-
- Create
- ("is_trivia",
- (1 => Param ("token", Kind_Token)),
- Eval_Token_Is_Trivia'Access,
- "Return whether this token is a trivia",
- Only_Dot_Calls => True),
-
- Create
- ("next",
- (Param ("token", Kind_Token),
- Param ("exclude_trivia", Kind_Bool, To_Primitive (False))),
- Eval_Token_Next'Access,
- "Return the next token",
- Only_Dot_Calls => True),
-
- Create
- ("previous",
- (Param ("token", Kind_Token),
- Param ("exclude_trivia", Kind_Bool, To_Primitive (False))),
- Eval_Token_Previous'Access,
- "Return the previous token",
- Only_Dot_Calls => True),
-
- Create
- ("start_column",
- (1 => Param ("token", Kind_Token)),
- Eval_Start_Col'Access,
- "Return the column start",
- Only_Dot_Calls => True),
-
- Create
- ("end_column",
- (1 => Param ("token", Kind_Token)),
- Eval_End_Col'Access,
- "Return the column end",
- Only_Dot_Calls => True),
-
- Create
- ("start_line",
- (1 => Param ("token", Kind_Token)),
- Eval_Start_Line'Access,
- "Return the line start",
- Only_Dot_Calls => True),
-
- Create
- ("end_line",
- (1 => Param ("token", Kind_Token)),
- Eval_End_Line'Access,
- "Return the line end",
- Only_Dot_Calls => True),
-
- Create
- ("unit",
- (1 => Param ("token", Kind_Token)),
- Eval_Token_Unit'Access,
- "Return the unit for this token",
- Only_Dot_Calls => True),
-
- -- Unit builtins
-
- Create
- ("text",
- (1 => Param ("unit", Kind_Analysis_Unit)),
- Eval_Unit_Text'Access,
- "Return the text for the whole unit",
- Only_Dot_Calls => True),
-
- Create
- ("root",
- (1 => Param ("unit", Kind_Analysis_Unit)),
- Eval_Unit_Root'Access,
- "Return the root for this unit",
- Only_Dot_Calls => True),
-
- Create
- ("name",
- (1 => Param ("unit", Kind_Analysis_Unit)),
- Eval_Unit_Name'Access,
- "Return the name of this unit",
- Only_Dot_Calls => True),
-
- Create
- ("tokens",
- (1 => Param ("unit", Kind_Analysis_Unit)),
- Eval_Unit_Tokens'Access,
- "Given an unit, return an iterator on its tokens",
- Only_Dot_Calls => True),
-
- Create
- ("pattern",
- (1 => Param ("string_pattern", Kind_Str),
- 2 => Param ("case_sensitive", Kind_Bool, To_Primitive (True))),
- Eval_Create_Pattern'Access,
- "Given a regex pattern string, create a pattern object",
- Only_Dot_Calls => False),
-
- Create
- ("find",
- (1 => Param ("string", Kind_Str),
- 2 => Param ("to_find")),
- Eval_Find'Access,
- "Search for `to_find` in the given string. "
- & "Return position of the match, or -1 if no match. "
- & "``to_find`` can be either a pattern or a string",
- Only_Dot_Calls => True),
-
- -- String builtins
-
- Create
- ("starts_with",
- (Param ("str", Kind_Str), Param ("prefix", Kind_Str)),
- Eval_Starts_With'Access,
- "Given a string, returns whether it starts with the given prefix",
- Only_Dot_Calls => True),
-
- Create
- ("ends_with",
- (Param ("str", Kind_Str), Param ("suffix", Kind_Str)),
- Eval_Ends_With'Access,
- "Given a string, returns whether it ends with the given suffix",
- Only_Dot_Calls => True),
-
- Create
- ("is_lower_case",
- (1 => Param ("str", Kind_Str)),
- Eval_Is_Lower_Case'Access,
- "Return whether the given string contains lower case characters "
- & "only",
- Only_Dot_Calls => True),
-
- Create
- ("is_upper_case",
- (1 => Param ("str", Kind_Str)),
- Eval_Is_Upper_Case'Access,
- "Return whether the given string contains upper case characters "
- & "only",
- Only_Dot_Calls => True),
-
- Create
- ("is_mixed_case",
- (1 => Param ("str", Kind_Str)),
- Eval_Is_Mixed_Case'Access,
- "Return whether the given string is written in mixed case, that is, "
- & "with only lower case characters except the first one and every "
- & "character following an underscore",
- Only_Dot_Calls => True),
-
- Create
- ("to_lower_case",
- (1 => Param ("str", Kind_Str)),
- Eval_To_Lower_Case'Access,
- "Return the given string written with lower case characters only",
- Only_Dot_Calls => True),
-
- Create
- ("concat",
- (1 => Param ("lists", Kind_List)),
- Eval_Concat'Access,
- "Given a list of lists or strings, return a concatenated list or "
- & "string"),
-
- Create
- ("contains",
- (Param ("str", Kind_Str), Param ("substr")),
- Eval_Contains'Access,
- "Search for `to_find` in the given string. "
- & "Return whether a match is found. "
- & "``to_find`` can be either a pattern or a string",
- Only_Dot_Calls => True),
-
- Create
- ("split",
- (Param ("str", Kind_Str), Param ("separator", Kind_Str)),
- Eval_Split'Access,
- "Given a string, return an iterator on the words contained by "
- & "str separated by separator",
- Only_Dot_Calls => True),
-
- Create
- ("substring",
- (Param ("str", Kind_Str),
- Param ("from", Kind_Int),
- Param ("to", Kind_Int)),
- Eval_Substring'Access,
- "Given a string and two indices (from and to), return the substring "
- & "contained between indices from and to (both included)",
- Only_Dot_Calls => True),
-
- Create
- ("base_name",
- (1 => Param ("str", Kind_Str)),
- Eval_Base_Name'Access,
- "Given a string that represents a file name, returns the basename"),
-
- Create
- ("doc",
- (1 => Param ("obj")),
- Eval_Doc'Access,
- "Given any object, return the documentation associated with it"),
-
- Create
- ("profile",
- (1 => Param ("obj")),
- Eval_Profile'Access,
- "Given any object, if it is a callable, return its profile as text"),
-
- Create
- ("get_symbols",
- (1 => Param ("package", Kind_Namespace, Make_Unit_Primitive)),
- Eval_Get_Symbols'Access,
- "Given a module, return the symbols stored in it. If given no module"
- & ", return the local symbols"),
-
- Create
- ("units",
- Empty_Profile,
- Eval_Units'Access,
- "Return an iterator on all units"),
-
- Create
- ("get_builtin_methods_info",
- Empty_Profile,
- Eval_Get_Builtin_Methods_Info'Access,
- "Return information about builtin methods"),
-
- Create
- ("help",
- (1 => Param ("obj")),
- Eval_Help'Access,
- "Given any object, return formatted help for it")
-
- );
-
- ------------------
- -- All_Builtins --
- ------------------
-
- function All_Builtins return Builtin_Function_Array is
- (Builtin_Functions);
-
- type Free_Builtins is new Ada.Finalization.Controlled with record
- Freed : Boolean := False;
- end record;
-
- overriding procedure Finalize (Self : in out Free_Builtins);
-
- --------------
- -- Finalize --
- --------------
-
- overriding procedure Finalize (Self : in out Free_Builtins) is
- procedure Free_Builtin_Fun is new Ada.Unchecked_Deallocation
- (Builtin_Function_Description, Builtin_Function);
- begin
- if not Self.Freed then
- for Fun of Builtin_Functions loop
- declare
- F : Builtin_Function := Fun;
- begin
- Free_Builtin_Fun (F);
- end;
- end loop;
- Self.Freed := True;
- end if;
- end Finalize;
-
- Free_Builtins_Singleton : aliased Free_Builtins;
- pragma Unreferenced (Free_Builtins_Singleton);
-
-end LKQL.Builtin_Functions;
diff --git a/lkql/extensions/src/lkql-builtin_functions.ads b/lkql/extensions/src/lkql-builtin_functions.ads
deleted file mode 100644
index 2f96f96d8..000000000
--- a/lkql/extensions/src/lkql-builtin_functions.ads
+++ /dev/null
@@ -1,44 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Primitives; use LKQL.Primitives;
-
--- This package declares every function that is a builtin in LKQL, and a
--- function that returns the array of builtin function descriptors that
--- lists all the functions and their name in LKQL.
---
--- To add a new built-in function, you must:
---
--- 1. Add a new function with the correct prototype in that package
---
--- 2. Register it in the list of built-ins (The ``Builtin_Functions`` array
--- in the body of this package).
-
-package LKQL.Builtin_Functions is
-
- type Builtin_Function_Array is
- array (Positive range <>) of Builtin_Function;
-
- function All_Builtins return Builtin_Function_Array;
-
-end LKQL.Builtin_Functions;
diff --git a/lkql/extensions/src/lkql-chained_pattern.adb b/lkql/extensions/src/lkql-chained_pattern.adb
deleted file mode 100644
index 61e20fbc4..000000000
--- a/lkql/extensions/src/lkql-chained_pattern.adb
+++ /dev/null
@@ -1,303 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Assertions; use Ada.Assertions;
-
-with LKQL.Node_Data;
-with LKQL.Error_Handling; use LKQL.Error_Handling;
-with LKQL.Patterns.Match; use LKQL.Patterns.Match;
-with LKQL.Patterns.Nodes; use LKQL.Patterns.Nodes;
-with LKQL.Selector_Lists; use LKQL.Selector_Lists;
-
-package body LKQL.Chained_Pattern is
-
- ----------
- -- Next --
- ----------
-
- overriding function Next (Iter : in out Chained_Pattern_Iterator;
- Result : out Match_Result)
- return Boolean
- is
- Current_Root : Lk_Node;
- begin
- while Iter.Next_Values.Is_Empty and then
- Iter.Root_Nodes_Iterator.Next (Current_Root)
- loop
- Iter.Eval_Element (Current_Root);
- end loop;
-
- if Iter.Next_Values.Is_Empty then
- return False;
- else
- Result := Iter.Next_Values.First_Element;
- Iter.Next_Values.Delete_First;
- return True;
- end if;
- end Next;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone (Iter : Chained_Pattern_Iterator)
- return Chained_Pattern_Iterator
- is
- begin
- Inc_Ref (Iter.Ctx.Frames);
- return
- (Ctx => Iter.Ctx,
- Next_Values => Iter.Next_Values,
- Pattern => Iter.Pattern,
- Root_Nodes_Iterator =>
- new Lk_Node_Iterator'Class'
- (Lk_Node_Iterator'Class
- ((Iter.Root_Nodes_Iterator.Clone))),
- Yielded_Elements => Node_Sets.Empty_Set);
- end Clone;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Iter : in out Chained_Pattern_Iterator) is
- begin
- Iter.Ctx.Release_Current_Frame;
- Lk_Node_Iterators.Free_Iterator (Iter.Root_Nodes_Iterator);
- end Release;
-
- -------------------------------
- -- Make_Chained_Pattern_Iter --
- -------------------------------
-
- function Make_Chained_Pattern_Iterator
- (Ctx : Eval_Context;
- Root_Iterator : Lk_Node_Iterator_Access;
- Pattern : L.Chained_Node_Pattern) return Chained_Pattern_Iterator
- is
- begin
- Inc_Ref (Ctx.Frames);
- return (Ctx => Ctx,
- Pattern => Pattern,
- Root_Nodes_Iterator => Root_Iterator,
- others => <>);
- end Make_Chained_Pattern_Iterator;
-
- ------------------
- -- Eval_Element --
- ------------------
-
- procedure Eval_Element
- (Iter : in out Chained_Pattern_Iterator;
- Root : Lk_Node)
- is
- Match : constant Match_Result :=
- Match_Pattern
- (Iter.Ctx,
- Iter.Pattern.F_First_Pattern,
- To_Primitive (Root, Iter.Ctx.Pool));
- begin
- if not Match.Is_Success then
- return;
- end if;
-
- Iter.Eval_Chain_From (Root, Link_Nb => 1);
- end Eval_Element;
-
- ---------------------
- -- Eval_Chain_From --
- ---------------------
-
- procedure Eval_Chain_From
- (Iter : in out Chained_Pattern_Iterator;
- Root : Lk_Node;
- Link_Nb : Positive)
- is
- begin
- if Link_Nb > Iter.Pattern.F_Chain.Children_Count and then
- not (Iter.Yielded_Elements.Contains (Root))
- then
- Iter.Next_Values.Append
- (Make_Match_Success (To_Primitive (Root, Iter.Ctx.Pool)));
- Iter.Yielded_Elements.Insert (Root);
- elsif Link_Nb <= Iter.Pattern.F_Chain.Children_Count then
- Iter.Eval_Chain_From_Link (Root, Link_Nb);
- end if;
- end Eval_Chain_From;
-
- --------------------------
- -- Eval_Chain_From_Link --
- --------------------------
-
- procedure Eval_Chain_From_Link
- (Iter : in out Chained_Pattern_Iterator;
- Root : Lk_Node;
- Link_Nb : Positive)
- is
- Link : constant L.Chained_Pattern_Link :=
- Iter.Pattern.F_Chain.List_Child (Link_Nb);
- Nodes : constant Lk_Node_Vector :=
- Eval_Link (Iter.Ctx, Root, Link);
- Pattern_Binding : constant Symbol_Type :=
- Symbol (Link.F_Pattern.P_Binding_Name);
- begin
- if Nodes.Is_Empty then
- return;
- end if;
-
- for E of Nodes loop
- if Pattern_Binding /= null then
- Iter.Ctx.Add_Binding (Pattern_Binding,
- To_Primitive (E, Iter.Ctx.Pool));
- end if;
-
- Eval_Chain_From (Iter, E, Link_Nb + 1);
- end loop;
- end Eval_Chain_From_Link;
-
- ---------------------
- -- Eval_Chain_Link --
- ---------------------
-
- function Eval_Link
- (Ctx : Eval_Context;
- Root : Lk_Node;
- Link : L.Chained_Pattern_Link) return Lk_Node_Vector
- is
- Pattern : L.Base_Pattern renames Link.F_Pattern;
- begin
- case Link.Kind is
- when LCO.Lkql_Selector_Link =>
- return Eval_Selector_Link
- (Ctx, Root, Link.As_Selector_Link);
- when LCO.Lkql_Field_Link =>
- return Filter_Node_Vector
- (Ctx, Pattern,
- Eval_Field_Link (Ctx, Root, Link.As_Field_Link));
- when LCO.Lkql_Property_Link =>
- return Filter_Node_Vector
- (Ctx, Pattern,
- Eval_Property_Link (Ctx, Root, Link.As_Property_Link));
- when others =>
- raise Assertion_Error with
- "Invalid chained pattern link kind: " & L.Kind_Name (Link);
- end case;
- end Eval_Link;
-
- ------------------------
- -- Eval_Selector_Link --
- ------------------------
-
- function Eval_Selector_Link
- (Ctx : Eval_Context;
- Root : Lk_Node;
- Selector : L.Selector_Link) return Lk_Node_Vector
- is
- S_List : Primitive;
- Call : constant L.Selector_Call := Selector.F_Selector;
- Binding_Name : constant Symbol_Type := Symbol (Call.P_Binding_Name);
- begin
- if not Eval_Selector
- (Ctx, Root, Call, Selector.F_Pattern, S_List)
- then
- return Lk_Node_Vectors.Empty_Vector;
- end if;
-
- if Binding_Name /= null then
- Ctx.Add_Binding (Binding_Name, S_List);
- end if;
-
- return S_List.Selector_List_Val.Nodes;
- end Eval_Selector_Link;
-
- ---------------------
- -- Eval_Field_Link --
- ---------------------
-
- function Eval_Field_Link
- (Ctx : Eval_Context;
- Root : Lk_Node;
- Field : L.Field_Link) return Lk_Node_Vector
- is
- use LKQL.Node_Data;
- Field_Value : constant Primitive :=
- Access_Node_Field (Ctx, Root, Field.F_Field);
- begin
- if Kind (Field_Value) /= Kind_Node
- and then Kind (Field_Value) /= Kind_List
- then
- Raise_Invalid_Kind
- (Ctx, Field.As_Lkql_Node, Kind_List, Field_Value);
- end if;
-
- return To_AST_Node_Vector (Field_Value);
- end Eval_Field_Link;
-
- ------------------------
- -- Eval_Property_Link --
- ------------------------
-
- function Eval_Property_Link
- (Ctx : Eval_Context;
- Root : Lk_Node;
- Property : L.Property_Link) return Lk_Node_Vector
- is
- use LKQL.Node_Data;
- Call : constant L.Fun_Call := Property.F_Property;
- Property_Value : constant Primitive :=
- Eval_Node_Property
- (Ctx, Root, Call.F_Name.As_Identifier, Call.F_Arguments);
- begin
- if Kind (Property_Value) /= Kind_Node
- and then Kind (Property_Value) /= Kind_List
- then
- Raise_Invalid_Kind
- (Ctx, Property.As_Lkql_Node, Kind_List, Property_Value);
- end if;
-
- return To_AST_Node_Vector (Property_Value);
- end Eval_Property_Link;
-
- -----------------------
- -- To_Ada_Node_Array --
- -----------------------
-
- function To_AST_Node_Vector (Value : Primitive) return Lk_Node_Vector is
- Result : Lk_Node_Vector;
- begin
- case Kind (Value) is
- when Kind_Node =>
- Result.Append (Node_Val (Value));
- when Kind_List =>
- for I in 1 .. Length (Value) loop
- Result.Append (Node_Val (Get (Value, I)));
- end loop;
- when others =>
- raise Assertion_Error with
- "Cannot make an ada node array from a value of kind: " &
- Kind_Name (Value);
- end case;
- return Result;
- end To_AST_Node_Vector;
-
-end LKQL.Chained_Pattern;
diff --git a/lkql/extensions/src/lkql-chained_pattern.ads b/lkql/extensions/src/lkql-chained_pattern.ads
deleted file mode 100644
index 6a8b47fab..000000000
--- a/lkql/extensions/src/lkql-chained_pattern.ads
+++ /dev/null
@@ -1,144 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Iters.Iterators;
-with LKQL.Patterns; use LKQL.Patterns;
-with LKQL.Primitives; use LKQL.Primitives;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with LKQL.Lk_Nodes_Iterators; use LKQL.Lk_Nodes_Iterators;
-
-with Ada.Containers.Hashed_Sets;
-with Ada.Containers.Doubly_Linked_Lists;
-
-private package LKQL.Chained_Pattern is
-
- package Match_Result_Lists is new
- Ada.Containers.Doubly_Linked_Lists (Match_Result);
- -- Lists of 'Match_Result' values
-
- subtype Match_Result_List is Match_Result_Lists.List;
- -- Lits of Match_Result values
-
- package Chained_Pattern_Iterators is
- new Iters.Iterators (Match_Result);
- -- Iterators of Match_Result values
-
- subtype Chained_Pattern_Iter
- is Chained_Pattern_Iterators.Iterator_Interface;
- -- Iterators of Match_Result values
-
- type Chained_Pattern_Iterator is new Chained_Pattern_Iter with private;
- -- Iterator that yields the values that belong to the result of a
- -- chained pattern.
-
- overriding function Next (Iter : in out Chained_Pattern_Iterator;
- Result : out Match_Result)
- return Boolean;
-
- overriding function Clone (Iter : Chained_Pattern_Iterator)
- return Chained_Pattern_Iterator;
-
- overriding procedure Release (Iter : in out Chained_Pattern_Iterator);
-
- function Make_Chained_Pattern_Iterator
- (Ctx : Eval_Context;
- Root_Iterator : Lk_Node_Iterator_Access;
- Pattern : L.Chained_Node_Pattern) return Chained_Pattern_Iterator;
- -- Return an iterator that yields every node that matches the given
- -- chained pattern.
-
-private
-
- package Node_Sets is new Ada.Containers.Hashed_Sets
- (Element_Type => Lk_Node,
- Hash => Hash,
- Equivalent_Elements => "=",
- "=" => "=");
- -- Sets of Ada nodes
-
- subtype Node_Set is Node_Sets.Set;
- -- Set of Ada nodes
-
- type Chained_Pattern_Iterator is new Chained_Pattern_Iter with record
- Ctx : Eval_Context;
- -- Context in which the patterns will be evaluated
-
- Next_Values : Match_Result_List;
- -- Next values to be yielded, along with the bindings created while
- -- matching the sub patterns.
-
- Pattern : L.Chained_Node_Pattern;
- -- THE pattern
-
- Root_Nodes_Iterator : Lk_Node_Iterator_Access;
- -- Iterator that yields the nodes that match the first pattern of the
- -- chain.
-
- Yielded_Elements : Node_Set;
- -- Cache storing the elements that have been yielded
- end record;
-
- procedure Eval_Element
- (Iter : in out Chained_Pattern_Iterator; Root : Lk_Node);
- -- Populate the 'Next_Values' list of 'Iter' by evaluating the pattern from
- -- 'Root'.
-
- procedure Eval_Chain_From
- (Iter : in out Chained_Pattern_Iterator;
- Root : Lk_Node;
- Link_Nb : Positive);
-
- procedure Eval_Chain_From_Link
- (Iter : in out Chained_Pattern_Iterator;
- Root : Lk_Node;
- Link_Nb : Positive)
- with Pre => Link_Nb <= Iter.Pattern.F_Chain.Children_Count;
-
- function Eval_Link
- (Ctx : Eval_Context;
- Root : Lk_Node;
- Link : L.Chained_Pattern_Link) return Lk_Node_Vector;
- -- Return the result of a link's evaluation.
- -- If the link introduces new bindings, they will be added to 'Bindings'.
- -- If 'Link' is a selector link, the related pattern is used to verify the
- -- quantifier.
-
- function Eval_Selector_Link
- (Ctx : Eval_Context;
- Root : Lk_Node;
- Selector : L.Selector_Link) return Lk_Node_Vector;
-
- function Eval_Field_Link
- (Ctx : Eval_Context;
- Root : Lk_Node;
- Field : L.Field_Link) return Lk_Node_Vector;
-
- function Eval_Property_Link
- (Ctx : Eval_Context;
- Root : Lk_Node;
- Property : L.Property_Link) return Lk_Node_Vector;
-
- function To_AST_Node_Vector
- (Value : Primitive) return Lk_Node_Vector;
-
-end LKQL.Chained_Pattern;
diff --git a/lkql/extensions/src/lkql-custom_selectors.adb b/lkql/extensions/src/lkql-custom_selectors.adb
deleted file mode 100644
index 85fc4dd4a..000000000
--- a/lkql/extensions/src/lkql-custom_selectors.adb
+++ /dev/null
@@ -1,328 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Patterns; use LKQL.Patterns;
-with LKQL.Patterns.Match; use LKQL.Patterns.Match;
-with LKQL.Evaluation; use LKQL.Evaluation;
-with LKQL.Error_Handling; use LKQL.Error_Handling;
-with LKQL.Adaptive_Integers; use LKQL.Adaptive_Integers;
-
-package body LKQL.Custom_Selectors is
-
- procedure Add_Selector_Expr (Iter : in out Custom_Selector_Iter;
- Local_Ctx : Eval_Context;
- Depth : Natural;
- Expr : L.Selector_Expr;
- Cache_Vector : Node_Vector);
- -- Add the result of 'Expr's evaluation to the values produced by the
- -- selector.
-
- procedure Add_Node (Iter : in out Custom_Selector_Iter;
- Current_Depth : Natural;
- Node : LK.Lk_Node;
- Mode : L.Selector_Expr_Mode;
- Cache_Vector : Node_Vector);
- -- Add the given node to the values produced by the selector.
- -- The value will be added to 'Next_Values' or 'Next_To_Visit' (or both)
- -- depending on the given mode.
-
- ----------
- -- Next --
- ----------
-
- function Next
- (Iter : in out Custom_Selector_Iter;
- Result : out Depth_Node) return Boolean
- is
- begin
- -- Eval the next selector call
- Iter.Eval_Selector;
-
- -- If there are no values in the queue
- if Iter.Next_Values.Is_Empty then
- -- Try to compute next values
- if Iter.Next_To_Visit.Is_Empty then
- -- If we end up here, we really have exhausted the selector,
- -- because it means that the call to eval selector didn't add
- -- values to return, nor values to visit.
- return False;
- else
- -- If we're here, there were no values to return, but there sare
- -- till be values to visit: Call Next recursively to eval the
- -- selector call on them.
- return Iter.Next (Result);
- end if;
- end if;
-
- -- Iterate over the values to return
- loop
- -- If there are no more values, then exit the loop
- exit when Iter.Next_Values.Is_Empty;
-
- -- Check the next value to return, and verify whether it's within the
- -- depth bounds.
- Result := Iter.Next_Values.First_Element;
-
- if Iter.Max_Depth >= 0 and then Result.Depth > Iter.Max_Depth then
- -- If it's over the depth bounds, just end the selector evaluation
- -- completely.
- return False;
- elsif Iter.Min_Depth >= 0 and then Result.Depth < Iter.Min_Depth then
- -- If it's below, we need to continue evaluating but just filter
- -- the values: keep going.
- Iter.Next_Values.Delete_First;
- else
- -- It's within bounds, return true
- Iter.Next_Values.Delete_First;
- return True;
- end if;
- end loop;
-
- -- Here, there might still be values to visit, so call Next recursively.
- return Iter.Next (Result);
- end Next;
-
- -----------
- -- Clone --
- -----------
-
- function Clone (Iter : Custom_Selector_Iter) return Custom_Selector_Iter is
- (Iter);
-
- -------------------------------
- -- Make_Custom_Selector_Iter --
- -------------------------------
-
- function Make_Custom_Selector_Iter
- (Ctx : Eval_Context;
- Selector : Primitive;
- Min_Depth_Expr, Max_Depth_Expr : L.Expr;
- Root : LK.Lk_Node)
- return Custom_Selector_Iter
- is
-
- Default_Min : constant Primitive := To_Primitive (1, Ctx.Pool);
- Min_Depth : constant Integer :=
- +Int_Val (Eval_Default (Ctx, Min_Depth_Expr, Default_Min,
- Expected_Kind => Kind_Int));
- Default_Max : constant Primitive := To_Primitive (-1, Ctx.Pool);
- Max_Depth : constant Integer :=
- +Int_Val (Eval_Default (Ctx, Max_Depth_Expr, Default_Max,
- Expected_Kind => Kind_Int));
- Root_Node : constant Depth_Node :=
- Depth_Node'(0, Root);
-
- Eval_Ctx : constant Eval_Context :=
- Eval_Context'(Ctx.Kernel,
- Eval_Contexts.Environment_Access (Selector.Frame));
- begin
- return Result : Custom_Selector_Iter do
- Result := Custom_Selector_Iter'
- (Eval_Ctx, Selector,
- Min_Depth, Max_Depth, others => <>);
-
- Result.Next_To_Visit.Append (Root_Node);
-
- if Min_Depth < 1 then
- Result.Next_Values.Append (Root_Node);
- end if;
- end return;
- end Make_Custom_Selector_Iter;
-
- -------------------
- -- Eval_Selector --
- -------------------
-
- procedure Eval_Selector (Iter : in out Custom_Selector_Iter) is
- use Depth_Node_Lists;
- Position : Cursor := Iter.Next_To_Visit.First;
- Node : Depth_Node;
- begin
- if not Has_Element (Position) then
- return;
- end if;
-
- Node := Element (Position);
- Iter.Next_To_Visit.Delete (Position);
- Eval_Selector (Iter, Node);
- end Eval_Selector;
-
- -------------------
- -- Eval_Selector --
- -------------------
-
- procedure Eval_Selector (Iter : in out Custom_Selector_Iter;
- Node : Depth_Node)
- is
- Has_Cache : constant Boolean := Iter.Selector.Sel_Cache /= null;
- Cache_Cursor : constant Node_To_Nodes.Cursor :=
- (if Has_Cache
- then Iter.Selector.Sel_Cache.Find (Node.Node)
- else Node_To_Nodes.No_Element);
- begin
- if Node_To_Nodes.Has_Element (Cache_Cursor) then
- declare
- Elements : constant Node_Vector :=
- Node_To_Nodes.Element (Cache_Cursor);
- begin
- for El of Elements.all loop
- Add_Node (Iter, Node.Depth, El.Node, El.Mode, null);
- end loop;
- end;
- else
- declare
- Local_Ctx : Eval_Context;
- Node_Value : constant Primitive :=
- To_Primitive (Node.Node, Iter.Ctx.Pool);
- Dummy : constant Primitive :=
- To_Primitive (Node.Depth, Iter.Ctx.Pool);
- Sel_Node : constant L.Selector_Decl := Iter.Selector.Sel_Node;
- Match_Data : constant Match_Array_Result :=
- Match_Pattern_Array (Iter.Ctx, Sel_Node.P_Patterns, Node_Value);
- Cache_Vector : constant Node_Vector :=
- (if Has_Cache then new Nodes_Vectors.Vector else null);
- begin
- if Match_Data.Index = 0 then
- return;
- end if;
-
- Local_Ctx := Iter.Ctx.Create_New_Frame;
- Local_Ctx.Add_Binding ("this", Node_Value);
- Local_Ctx.Add_Binding
- ("depth", To_Primitive (Node.Depth, Iter.Ctx.Pool));
-
- for E of Sel_Node.P_Nth_Expressions (Match_Data.Index) loop
- Add_Selector_Expr
- (Iter, Local_Ctx, Node.Depth,
- E.As_Selector_Expr, Cache_Vector);
- end loop;
-
- Local_Ctx.Release_Current_Frame;
-
- if Has_Cache then
- Iter.Selector.Sel_Cache.Include (Node.Node, Cache_Vector);
- end if;
- end;
- end if;
- end Eval_Selector;
-
- -----------------------
- -- Add_Selector_Expr --
- -----------------------
-
- procedure Add_Selector_Expr (Iter : in out Custom_Selector_Iter;
- Local_Ctx : Eval_Context;
- Depth : Natural;
- Expr : L.Selector_Expr;
- Cache_Vector : Node_Vector)
- is
- use type LCO.Lkql_Node_Kind_Type;
-
- Expr_Value : constant Primitive :=
- (if Expr.F_Expr.Kind = LCO.Lkql_Unpack
- then Eval (Local_Ctx, Expr.F_Expr.As_Unpack.F_Collection_Expr)
- else Eval (Local_Ctx, Expr.F_Expr));
-
- begin
- if Kind (Expr_Value) = Kind_Node then
- Add_Node
- (Iter, Depth, Node_Val (Expr_Value), Expr.F_Mode, Cache_Vector);
-
- -- TODO: This only handles lists, we should handle any kind of sequence
- -- here.
- elsif Kind (Expr_Value) = Kind_List and then
- Expr.F_Expr.Kind = LCO.Lkql_Unpack
- then
- for N of List_Val (Expr_Value).Elements loop
- Add_Node (Iter, Depth, Node_Val (N), Expr.F_Mode, Cache_Vector);
- end loop;
- elsif Kind (Expr_Value) = Kind_Unit then
- return;
- else
- Raise_Invalid_Kind_For_Selector (Local_Ctx, Expr, Expr_Value);
- end if;
- end Add_Selector_Expr;
-
- --------------
- -- Add_Node --
- --------------
-
- procedure Add_Node
- (Iter : in out Custom_Selector_Iter;
- Current_Depth : Natural;
- Node : LK.Lk_Node;
- Mode : L.Selector_Expr_Mode;
- Cache_Vector : Node_Vector)
- is
- procedure Add_If_Unseen
- (Node : Depth_Node;
- Cache : in out Node_Sets.Set;
- Target_List : out Depth_Node_Lists.List);
- -- Add 'Node' to the target list if it's node value is not already in
- -- the cache, and cache it.
-
- use type LCO.Lkql_Node_Kind_Type;
-
- Depth_Offset : constant Integer :=
- (if Mode.Kind = LCO.Lkql_Selector_Expr_Mode_Skip then 0 else 1);
-
- With_Depth : constant Depth_Node :=
- Depth_Node'(Current_Depth + Depth_Offset, Node);
-
- -------------------
- -- Add_If_Unseen --
- -------------------
-
- procedure Add_If_Unseen
- (Node : Depth_Node;
- Cache : in out Node_Sets.Set;
- Target_List : out Depth_Node_Lists.List) is
- begin
- if Cache.Contains (Node.Node) then
- return;
- end if;
-
- Cache.Insert (Node.Node);
- Target_List.Append (Node);
- end Add_If_Unseen;
-
- begin
- if Node.Is_Null then
- return;
- end if;
-
- -- If the node's depth is too low we want to visit it without adding
- -- it to the list of nodes to be yielded.
- if Mode.Kind /= LCO.Lkql_Selector_Expr_Mode_Skip then
- if Cache_Vector /= null then
- Cache_Vector.Append ((Node, Mode));
- end if;
- Add_If_Unseen (With_Depth, Iter.Already_Yielded, Iter.Next_Values);
- end if;
-
- if Mode.Kind /= LCO.Lkql_Selector_Expr_Mode_Default then
- Add_If_Unseen (With_Depth, Iter.Already_Visited, Iter.Next_To_Visit);
- end if;
- end Add_Node;
-
-end LKQL.Custom_Selectors;
diff --git a/lkql/extensions/src/lkql-custom_selectors.ads b/lkql/extensions/src/lkql-custom_selectors.ads
deleted file mode 100644
index 81cc3532c..000000000
--- a/lkql/extensions/src/lkql-custom_selectors.ads
+++ /dev/null
@@ -1,106 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Depth_Nodes; use LKQL.Depth_Nodes;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-
-with Ada.Containers.Doubly_Linked_Lists;
-with Ada.Containers.Hashed_Sets;
-with LKQL.Primitives; use LKQL.Primitives;
-
-private package LKQL.Custom_Selectors is
-
- type Custom_Selector_Iter is new Depth_Node_Iter with private;
- -- Iterator that yields the nodes produced by a custom selector
-
- function Next
- (Iter : in out Custom_Selector_Iter;
- Result : out Depth_Node) return Boolean;
-
- function Clone (Iter : Custom_Selector_Iter) return Custom_Selector_Iter;
-
- function Make_Custom_Selector_Iter
- (Ctx : Eval_Context;
- Selector : Primitive;
- Min_Depth_Expr, Max_Depth_Expr : L.Expr;
- Root : LK.Lk_Node)
- return Custom_Selector_Iter;
- -- Create an iterator that yields the nodes bound to 'Root' by
- -- the given selector definition.
-
-private
-
- package Depth_Node_Lists is new Ada.Containers.Doubly_Linked_Lists
- (Depth_Node);
- -- List of Depth_Node values
-
- package Node_Sets is new Ada.Containers.Hashed_Sets
- (Element_Type => LK.Lk_Node,
- Hash => LK.Hash,
- Equivalent_Elements => LK."=",
- "=" => LK."=");
- -- Set of Depth_Node values
-
- type Custom_Selector_Iter is new Depth_Node_Iter with record
- Ctx : Eval_Context;
- -- Copy of the evaluation context
-
- Selector : Primitive;
- -- LKQL definition of the custom selector
-
- Min_Depth : Integer;
- -- Minimum depth of the nodes. If Min_Depth < 0, the minimum depth will
- -- be ignored.
-
- Max_Depth : Integer;
- -- Maximum depth of the nodes. If Max_Depth < 0, the maximum depth will
- -- be ignored.
-
- Next_Values : Depth_Node_Lists.List;
- -- Nodes that will be yielded
-
- Next_To_Visit : Depth_Node_Lists.List;
- -- Nodes that will be used as an evaluation root for the selector in
- -- order to find new nodes to yield.
-
- Already_Yielded : Node_Sets.Set;
- -- Nodes that have already been yielded
-
- Already_Visited : Node_Sets.Set;
- -- Nodes that have already been visited
- end record;
-
- procedure Eval_Selector (Iter : in out Custom_Selector_Iter);
- -- Remove the first value from the 'Next_To_Visit' list and use it as the
- -- root for the selector's evaluation.
- -- The 'Next_Values' and 'Next_To_Visit' lists will be updated with the
- -- values produced by the selector.
-
- procedure Eval_Selector (Iter : in out Custom_Selector_Iter;
- Node : Depth_Node);
- -- Remove the first value from the 'Next_To_Visit' list and use it as the
- -- root for the selector's evaluation.
- -- The 'Next_Values' and 'Next_To_Visit' lists will be updated with the
- -- values produced by the selector.
-
-end LKQL.Custom_Selectors;
diff --git a/lkql/extensions/src/lkql-depth_nodes.adb b/lkql/extensions/src/lkql-depth_nodes.adb
deleted file mode 100644
index b3a8d8103..000000000
--- a/lkql/extensions/src/lkql-depth_nodes.adb
+++ /dev/null
@@ -1,90 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Containers; use Ada.Containers;
-with Ada.Unchecked_Deallocation;
-
-package body LKQL.Depth_Nodes is
-
- ----------
- -- Hash --
- ----------
-
- function Hash (Value : Depth_Node) return Ada.Containers.Hash_Type is
- (LK.Hash (Value.Node));
-
- ----------
- -- Next --
- ----------
-
- overriding function Next
- (Iter : in out Depth_Node_Lk_Node_Iterator;
- Result : out LK.Lk_Node) return Boolean
- is
- D : Depth_Node;
- Res : Boolean;
- begin
- Res := Iter.Internal.Next (D);
- if Res then
- Result := D.Node;
- return True;
- end if;
- return False;
- end Next;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone
- (Iter : Depth_Node_Lk_Node_Iterator) return Depth_Node_Lk_Node_Iterator is
- begin
- raise Constraint_Error with "not implemented";
- return Depth_Node_Lk_Node_Iterator'
- (Internal => null);
- end Clone;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Iter : in out Depth_Node_Lk_Node_Iterator) is
- procedure Free is new Ada.Unchecked_Deallocation
- (Depth_Node_Iter'Class, Depth_Node_Iter_Access);
- begin
- Iter.Internal.Release;
- Free (Iter.Internal);
- end Release;
-
- -------------------------
- -- To_Lk_Node_Iterator --
- -------------------------
-
- function To_Lk_Node_Iterator
- (Self : Depth_Node_Iter'Class) return Lk_Node_Iterator'Class is
- begin
- return Depth_Node_Lk_Node_Iterator'
- (Internal => new Depth_Node_Iter'Class'(Self));
- end To_Lk_Node_Iterator;
-
-end LKQL.Depth_Nodes;
diff --git a/lkql/extensions/src/lkql-depth_nodes.ads b/lkql/extensions/src/lkql-depth_nodes.ads
deleted file mode 100644
index 7aed5b024..000000000
--- a/lkql/extensions/src/lkql-depth_nodes.ads
+++ /dev/null
@@ -1,95 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Containers;
-with Ada.Containers.Vectors;
-
-with Langkit_Support.Generic_API.Analysis;
-
-with Options;
-with Iters.Iterators;
-with LKQL.Lk_Nodes_Iterators; use LKQL.Lk_Nodes_Iterators;
-
-package LKQL.Depth_Nodes is
-
- package LK renames Langkit_Support.Generic_API.Analysis;
-
- type Depth_Node is record
- Depth : Natural;
- Node : LK.Lk_Node;
- end record;
- -- Depth-mapped AST node used in (and returned by) selectors
-
- package Depth_Node_Vectors is new Ada.Containers.Vectors
- (Positive, Depth_Node);
- -- Vectors of Depth_Node values
-
- subtype Depth_Node_Vector is Depth_Node_Vectors.Vector;
- -- Vector of Depth_Node values
-
- package Depth_Node_Iters is new Iters.Iterators (Depth_Node);
- -- Iterators over Depth_Node values
-
- subtype Depth_Node_Iter is
- Depth_Node_Iters.Iterator_Interface;
- -- Interface implemented by iterators over Depth_Node values
-
- subtype Depth_Node_Iter_Access is Depth_Node_Iters.Iterator_Access;
- -- Pointer to an iterator over Depth_Node values
-
- package Depth_Node_Options is new Options (Depth_Node);
- -- Optional Depth_Node values
-
- subtype Depth_Node_Option is Depth_Node_Options.Option;
- -- Optional Depth_Node value
-
- type Depth_Node_Array is array (Positive range <>) of Depth_Node;
-
- function Hash (Value : Depth_Node) return Ada.Containers.Hash_Type;
- -- Return the has of a Depth_Node value.
- -- The hash is computed by xoring the hash of the ast node and its
- -- depth value.
-
- function To_Lk_Node_Iterator
- (Self : Depth_Node_Iter'Class) return Lk_Node_Iterator'Class;
- -- Transform a depth node iterator into a basic ``Lk_Node_Iterator``. Note
- -- that this takes ownership of the original iterator, which shouldn't be
- -- reused afterwards! If you want to retain the original iterator, pass a
- -- clone to this function.
-
-private
-
- type Depth_Node_Lk_Node_Iterator is new Lk_Node_Iterator with record
- Internal : Depth_Node_Iter_Access;
- end record;
-
- overriding function Next
- (Iter : in out Depth_Node_Lk_Node_Iterator;
- Result : out LK.Lk_Node) return Boolean;
-
- overriding function Clone
- (Iter : Depth_Node_Lk_Node_Iterator) return Depth_Node_Lk_Node_Iterator;
-
- overriding procedure Release (Iter : in out Depth_Node_Lk_Node_Iterator);
-
-end LKQL.Depth_Nodes;
diff --git a/lkql/extensions/src/lkql-error_handling.adb b/lkql/extensions/src/lkql-error_handling.adb
deleted file mode 100644
index 9b62d5003..000000000
--- a/lkql/extensions/src/lkql-error_handling.adb
+++ /dev/null
@@ -1,292 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package body LKQL.Error_Handling is
-
- ----------------------------
- -- Raise_And_Record_Error --
- ----------------------------
-
- procedure Raise_And_Record_Error
- (Ctx : Eval_Context; Error : Error_Data)
- is
- Error_Message : constant String :=
- To_UTF8 (To_Text (Error.Short_Message));
- begin
- Ctx.Add_Error (Error);
-
- raise Stop_Evaluation_Error with Error_Message;
- end Raise_And_Record_Error;
-
- --------------------------
- -- Raise_From_Exception --
- --------------------------
-
- procedure Raise_From_Exception
- (Ctx : Eval_Context; E : Exception_Occurrence; N : L.Lkql_Node'Class) is
- begin
- Raise_And_Record_Error
- (Ctx,
- Error_Data'
- (Eval_Error,
- N.As_Lkql_Node,
- To_Unbounded_Text (To_Text (Exception_Message (E))),
- Property_Error_Info => null));
- end Raise_From_Exception;
-
- --------------------------
- -- Raise_Invalid_Member --
- --------------------------
-
- procedure Raise_Invalid_Member (Ctx : Eval_Context;
- Node : L.Dot_Access;
- Receiver : Primitive)
- is
- begin
- Raise_Invalid_Member (Ctx, Node.F_Member, Receiver);
- end Raise_Invalid_Member;
-
- --------------------------
- -- Raise_Invalid_Member --
- --------------------------
-
- procedure Raise_Invalid_Member (Ctx : Eval_Context;
- Node : L.Identifier;
- Receiver : Primitive)
- is
- Message : constant Text_Type :=
- "Cannot get member " & Node.Text & " for " &
- To_Text (Kind_Name (Receiver)) & " value";
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Node, Message));
- end Raise_Invalid_Member;
-
- ---------------------
- -- Raise_Null_Root --
- ---------------------
-
- procedure Raise_Null_Root (Ctx : Eval_Context; Node : L.Query)
- is
- Message : constant Text_Type :=
- "Cannot run a query without a proper AST root";
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Node, Message));
- end Raise_Null_Root;
-
- ------------------------
- -- Raise_Invalid_Type --
- ------------------------
-
- procedure Raise_Invalid_Type (Ctx : Eval_Context;
- Node : L.Lkql_Node;
- Expected : Text_Type;
- Value : Primitive)
- is
- Message : constant Text_Type :=
- "Type error: expected " & Expected &
- " but got " & To_Text (Kind_Name (Value));
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Node, Message));
- end Raise_Invalid_Type;
-
- ------------------------
- -- Raise_Invalid_Kind --
- ------------------------
-
- procedure Raise_Invalid_Kind (Ctx : Eval_Context;
- Node : L.Lkql_Node;
- Expected : Valid_Primitive_Kind;
- Value : Primitive)
- is
- Message : constant Text_Type :=
- "Type error: expected " & To_Text (To_String (Expected)) &
- " but got " & To_Text (Kind_Name (Value));
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Node, Message));
- end Raise_Invalid_Kind;
-
- ---------------------------------
- -- Raise_Invalid_Selector_Name --
- ---------------------------------
-
- procedure Raise_Invalid_Selector_Name (Ctx : Eval_Context;
- Node : L.Identifier)
- is
- Message : constant Text_Type := "Invalid selector name: " & Node.Text;
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Node, Message));
- end Raise_Invalid_Selector_Name;
-
- --------------------------
- -- Raise_Unknown_Symbol --
- --------------------------
-
- procedure Raise_Unknown_Symbol (Ctx : Eval_Context;
- Node : L.Identifier)
- is
- Message : constant Text_Type := "Unknown symbol: " & Node.Text;
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Node, Message));
- end Raise_Unknown_Symbol;
-
- -----------------------------------
- -- Raise_already_Existing_Symbol --
- -----------------------------------
-
- procedure Raise_Already_Existing_Symbol (Ctx : Eval_Context;
- Identifier : Symbol_Type;
- Node : L.Lkql_Node)
- is
- Message : constant Text_Type :=
- "Already existing symbol: " & Identifier.all;
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Node, Message));
- end Raise_Already_Existing_Symbol;
-
- -------------------------
- -- Raise_Invalid_Arity --
- -------------------------
-
- procedure Raise_Invalid_Arity (Ctx : Eval_Context;
- Expected_Arity : Natural;
- Arguments : L.Arg_List)
- is
- Expected : constant Text_Type :=
- Integer'Wide_Wide_Image (Expected_Arity);
- Actual_Arity : constant Text_Type :=
- Integer'Wide_Wide_Image (Arguments.Children_Count);
- Message : constant Text_Type :=
- "Expected" & Expected & " arguments but got" & Actual_Arity;
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Arguments, Message));
- end Raise_Invalid_Arity;
-
- ----------------------------
- -- Raise_Unknown_Argument --
- ----------------------------
-
- procedure Raise_Unknown_Argument (Ctx : Eval_Context;
- Identifier : L.Identifier)
- is
- Message : constant Text_Type :=
- "Unknown argument name: " & Identifier.Text;
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Identifier, Message));
- end Raise_Unknown_Argument;
-
- -----------------------------------
- -- Raise_Positionnal_After_Named --
- -----------------------------------
-
- procedure Raise_Positionnal_After_Named (Ctx : Eval_Context;
- Positionnal : L.Expr_Arg)
- is
- Message : constant Text_Type :=
- "Positional argument after named argument";
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Positionnal, Message));
- end Raise_Positionnal_After_Named;
-
- ----------------------------
- -- Raise_Already_Seen_Arg --
- ----------------------------
-
- procedure Raise_Already_Seen_Arg (Ctx : Eval_Context; Arg : L.Arg)
- is
- Message : constant Text_Type :=
- "Multiple arguments with the same name";
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Arg, Message));
- end Raise_Already_Seen_Arg;
-
- -------------------------------------
- -- Raise_Invalid_Kind_For_Selector --
- -------------------------------------
-
- procedure Raise_Invalid_Kind_For_Selector (Ctx : Eval_Context;
- Node : L.Lkql_Node'Class;
- Value : Primitive)
- is
- Value_Kind_Name : constant Text_Type := To_Text (Kind_Name (Value));
- Message : constant Text_Type :=
- "Cannot use values of kind " & Value_Kind_Name & " in a selector";
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Node, Message));
- end Raise_Invalid_Kind_For_Selector;
-
- -------------------------
- -- Raise_No_Such_Field --
- -------------------------
-
- procedure Raise_No_Such_Field (Ctx : Eval_Context;
- Node : Lk_Node;
- Field_Name : L.Identifier)
- is
- begin
- Raise_No_Such_Datum (Ctx, Node, Field_Name, "field");
- end Raise_No_Such_Field;
-
- ----------------------------
- -- Raise_No_Such_Property --
- ----------------------------
-
- procedure Raise_No_Such_Property (Ctx : Eval_Context;
- Node : Lk_Node;
- Property_Name : L.Identifier)
- is
- begin
- Raise_No_Such_Datum (Ctx, Node, Property_Name, "property");
- end Raise_No_Such_Property;
-
- -------------------------
- -- Raise_No_Such_Datum --
- -------------------------
-
- procedure Raise_No_Such_Datum (Ctx : Eval_Context;
- Node : Lk_Node;
- Field_Name : L.Identifier;
- Data_Type_Name : Text_Type)
- is
- Message : constant Text_Type :=
- "No " & Data_Type_Name & " named " & Field_Name.Text & " on nodes of" &
- " kind: " & To_Text (LKI.Debug_Name (LKI.Type_Of (Node)));
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Field_Name, Message));
- end Raise_No_Such_Datum;
-
- -----------------------
- -- Raise_Null_Access --
- -----------------------
-
- procedure Raise_Null_Access (Ctx : Eval_Context;
- Node : Primitive;
- Member_Name : L.Identifier)
- is
- Message : constant Text_Type :=
- To_Text ("Invalid direct access on node of kind ") &
- To_Text (Kind_Name (Node));
- begin
- Raise_And_Record_Error (Ctx, Make_Eval_Error (Member_Name, Message));
- end Raise_Null_Access;
-
-end LKQL.Error_Handling;
diff --git a/lkql/extensions/src/lkql-error_handling.ads b/lkql/extensions/src/lkql-error_handling.ads
deleted file mode 100644
index 9a0956a9d..000000000
--- a/lkql/extensions/src/lkql-error_handling.ads
+++ /dev/null
@@ -1,182 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Exceptions; use Ada.Exceptions;
-
-with Langkit_Support.Generic_API.Analysis;
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-with LKQL.Errors; use LKQL.Errors;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with LKQL.Primitives; use LKQL.Primitives;
-
-private package LKQL.Error_Handling is
-
- package LK renames Langkit_Support.Generic_API.Analysis;
-
- procedure Raise_And_Record_Error
- (Ctx : Eval_Context; Error : Error_Data)
- with No_Return;
- -- Add the given error to the evaluation context and:
- -- * raise a Recoverable_Error if error recovery is enabled and the
- -- user chooses to ignore the error
- -- * raise a Stop_Evaluation_Error if error recovery is disabled or the
- -- user chooses not to ignore the error
-
- procedure Raise_From_Exception
- (Ctx : Eval_Context; E : Exception_Occurrence; N : L.Lkql_Node'Class)
- with No_Return;
- -- Shortcut around ``Raise_And_Record_Error`` that raises from an exception
- -- occurrence.
-
- procedure Raise_Invalid_Member (Ctx : Eval_Context;
- Node : L.Dot_Access;
- Receiver : Primitive)
- with No_Return;
- -- Raise an exception signaling an invalid member access, and add an
- -- Error_Data describing the error to the evaluation context.
-
- procedure Raise_Invalid_Member (Ctx : Eval_Context;
- Node : L.Identifier;
- Receiver : Primitive)
- with No_Return;
- -- Raise an exception signaling an invalid member access, and add an
- -- Error_Data describing the error to the evaluation context.
-
- procedure Raise_Null_Root (Ctx : Eval_Context; Node : L.Query)
- with No_Return;
- -- Raise an exception signaling the absence of a proper AST root while
- -- trying to execute a query, and add an Error_Data describing the error
- -- to the evaluation context.
-
- procedure Raise_Invalid_Type (Ctx : Eval_Context;
- Node : L.Lkql_Node;
- Expected : Text_Type;
- Value : Primitive)
- with No_Return;
- -- Raise an exception signaling a type error, and add an Error_Data
- -- describing the error to the evaluation context.
-
- procedure Raise_Invalid_Kind (Ctx : Eval_Context;
- Node : L.Lkql_Node;
- Expected : Valid_Primitive_Kind;
- Value : Primitive)
- with No_Return;
- -- Raise an exception signaling a type error, and add an Error_Data
- -- describing the error to the evaluation context.
-
- procedure Raise_Invalid_Selector_Name (Ctx : Eval_Context;
- Node : L.Identifier)
- with No_Return;
- -- Raise an exception signaling the use of an invalid selector name,
- -- and add an Error_Data describing the error to the evaluation context.
-
- procedure Raise_Unknown_Symbol (Ctx : Eval_Context;
- Node : L.Identifier)
- with No_Return;
- -- Raise an exception signaling the use of an unknown identifier,
- -- and add an Error_Data describing the error to the evaluation context.
-
- procedure Raise_Already_Existing_Symbol (Ctx : Eval_Context;
- Identifier : Symbol_Type;
- Node : L.Lkql_Node)
- with No_Return;
- -- Raise an exception signaling an attempt to create a binding using a name
- -- that is already bound to a value in the local context,
- -- and add an Error_Data describing the error to the evaluation context.
-
- procedure Raise_Invalid_Arity (Ctx : Eval_Context;
- Expected_Arity : Natural;
- Arguments : L.Arg_List)
- with No_Return;
- -- Raise an exception signaling an attempt to call a function with an
- -- incorrect number of arguments,
- -- and add an Error_Data describing the error to the evaluation context.
-
- procedure Raise_Unknown_Argument (Ctx : Eval_Context;
- Identifier : L.Identifier)
- with No_Return;
- -- Raise an exception signaling an attempt to call a function with an
- -- argument which name doesn't match the name of a parameter, and add an
- -- Error_Data describing the error to the evaluation context.
-
- procedure Raise_Positionnal_After_Named (Ctx : Eval_Context;
- Positionnal : L.Expr_Arg)
- with No_Return;
- -- Raise an exception signaling the use of a positional argument after a
- -- named argument, and add an Error_Data describing the error to the
- -- evaluation context.
-
- procedure Raise_Already_Seen_Arg (Ctx : Eval_Context; Arg : L.Arg)
- with No_Return;
- -- Raise an exception signaling an attempt to call a function with
- -- at least two identically-named arguments.
-
- procedure Raise_Invalid_Kind_For_Selector (Ctx : Eval_Context;
- Node : L.Lkql_Node'Class;
- Value : Primitive)
- with No_Return;
- -- Raise an exception signaling the use of a value that is neither a node
- -- or an unpacked collection of nodes in a selector, and add an Error_Data
- -- describing the error to the evaluation context.
-
- procedure Raise_No_Such_Field (Ctx : Eval_Context;
- Node : LK.Lk_Node;
- Field_Name : L.Identifier)
- with No_Return;
- -- Raise an exception signaling an attempt to access a field that doesn't
- -- exists, and add an Error_Data describing the error to the evaluation
- -- context.
-
- procedure Raise_No_Such_Property (Ctx : Eval_Context;
- Node : LK.Lk_Node;
- Property_Name : L.Identifier)
- with No_Return;
- -- Raise an exception signaling an attempt to access a property that
- -- doesn't exists, and add an Error_Data describing the error to the
- -- evaluation context.
-
- procedure Raise_Null_Access (Ctx : Eval_Context;
- Node : Primitive;
- Member_Name : L.Identifier)
- with No_Return,
- Pre => Kind (Node) = Kind_Node;
- -- Raise an exception signaling an attempt to directly access a
- -- field/property on a nullable node, and add an Error_Data describing the
- -- error to the evaluation context.
-
-private
-
- type Data_Type is (Field, Property);
-
- procedure Raise_No_Such_Datum (Ctx : Eval_Context;
- Node : LK.Lk_Node;
- Field_Name : L.Identifier;
- Data_Type_Name : Text_Type)
- with No_Return;
- -- Raise an exception signaling an attempt to access a node datum that
- -- doesn't exist, and add an Error_Data describing the error to the
- -- evaluation context.
- -- Data_Type_Name = "field" or "property".
-
-end LKQL.Error_Handling;
diff --git a/lkql/extensions/src/lkql-errors.adb b/lkql/extensions/src/lkql-errors.adb
deleted file mode 100644
index e47f8c7d9..000000000
--- a/lkql/extensions/src/lkql-errors.adb
+++ /dev/null
@@ -1,133 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.String_Utils; use LKQL.String_Utils;
-
-with Langkit_Support.Slocs; use Langkit_Support.Slocs;
-
-with Ada.Strings.Wide_Wide_Unbounded; use Ada.Strings.Wide_Wide_Unbounded;
-
-package body LKQL.Errors is
-
- function Underline_Error (Lines : String_Vectors.Vector;
- Location : Source_Location_Range)
- return Unbounded_Text_Type;
- -- Return a String representing the source code containing the error, where
- -- the location of the error has been underlined.
-
- function Error_Description (Ast_Node : L.Lkql_Node;
- Message : Unbounded_Text_Type)
- return Unbounded_Text_Type;
- -- Return a detailed description of the error with the given message that
- -- occured durint the evaluation of 'Ast_Node'.
-
- ----------------------
- -- Underline_Error --
- ----------------------
-
- function Underline_Error (Lines : String_Vectors.Vector;
- Location : Source_Location_Range)
- return Unbounded_Text_Type
- is
- Result : Unbounded_Text_Type;
- Start_Col : constant Integer := Integer (Location.Start_Column);
- End_Col : constant Integer := Integer (Location.End_Column);
- Start_Line : constant Integer := Integer (Location.Start_Line);
- End_Line : constant Integer := Integer (Location.End_Line);
- begin
- if Start_Line = End_Line then
- return Underline_Range (Lines (Start_Line), Start_Col, End_Col);
- end if;
-
- Append (Result, Underline_From (Lines (Start_Line), Start_Col));
-
- for I in Start_Line + 1 .. End_Line - 1 loop
- Append (Result, Underline (Lines (I)));
- end loop;
-
- if Location.Start_Line /= Location.End_Line then
- Append (Result, Underline_To (Lines (End_Line), End_Col));
- end if;
-
- return Result;
- end Underline_Error;
-
- -----------------------
- -- Error_description --
- -----------------------
-
- function Error_Description (Ast_Node : L.Lkql_Node;
- Message : Unbounded_Text_Type)
- return Unbounded_Text_Type
- is
- use Langkit_Support.Text.Chars;
- Error_Unit : constant L.Analysis_Unit := Ast_Node.Unit;
- Error_Msg : constant Unbounded_Text_Type :=
- "Error: " & Message;
- Unit_Lines : constant String_Vectors.Vector :=
- Split_Lines (Error_Unit.Text);
- Underlined : constant Unbounded_Text_Type :=
- Underline_Error (Unit_Lines, Ast_Node.Sloc_Range);
- begin
- return LF & Error_Msg & LF & LF & Underlined;
- end Error_Description;
-
- ------------------------
- -- Error_Description --
- ------------------------
-
- function Error_Description (Error : Error_Data) return Unbounded_Text_Type
- is (case Error.Kind is
- when No_Error =>
- To_Unbounded_Text ("No error"),
- when Eval_Error =>
- Error_Description (Error.AST_Node, Error.Short_Message));
-
- --------------
- -- Is_Error --
- --------------
-
- function Is_Error (Err : Error_Data) return Boolean is
- (Err.Kind /= No_Error);
-
- ----------------------
- -- Make_Empty_Error --
- ----------------------
-
- function Make_Empty_Error return Error_Data is (Kind => No_Error);
-
- ---------------------
- -- Make_Eval_Error --
- ---------------------
-
- function Make_Eval_Error
- (AST_Node : L.Lkql_Node'Class;
- Short_Message : Text_Type;
- Property_Error_Info : Exception_Occurrence_Access := null)
- return Error_Data
- is (Kind => Eval_Error,
- AST_Node => AST_Node.As_Lkql_Node,
- Short_Message => To_Unbounded_Text (Short_Message),
- Property_Error_Info => Property_Error_Info);
-
-end LKQL.Errors;
diff --git a/lkql/extensions/src/lkql-errors.ads b/lkql/extensions/src/lkql-errors.ads
deleted file mode 100644
index d635f86c6..000000000
--- a/lkql/extensions/src/lkql-errors.ads
+++ /dev/null
@@ -1,94 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Exceptions; use Ada.Exceptions;
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-package LKQL.Errors is
-
- type Property_Error_Recovery_Kind is
- (Continue_And_Warn, Continue_And_Log, Raise_Error);
- -- Type to describe the behavior of LKQL when a property error happens
- -- inside a query.
- --
- -- * Continue_And_Warn will emit a warning/diagnostic on stderr and
- -- continue.
- --
- -- * Continue_And_Log will just log the error on a trace and continue. Use
- -- it in cases where LKQL is embedded and you don't want to emit anything
- -- on stderr.
- --
- -- * Raise_Error will bubble up the error.
-
- Property_Error_Recovery : Property_Error_Recovery_Kind := Continue_And_Log;
-
- Stop_Evaluation_Error : exception;
- -- This type of exception is used to signal that the execution should not
- -- be resumed. WARNING: THIS SHOULD NEVER BE RAISED MANUALLY but instead
- -- be raised via ``Raise_And_Record_Error``.
-
- type Error_Kind is
- (No_Error,
- -- Absence of error
- Eval_Error
- -- Error originating from the execution of the LKQL program
- );
- -- Denotes the kind of an error value.
-
- type Error_Data (Kind : Error_Kind := No_Error) is record
- case Kind is
- when No_Error =>
- null;
- -- Represents the absence of error
- when Eval_Error =>
- AST_Node : L.Lkql_Node;
- -- Node whose evaluation triggered this error
-
- Short_Message : Unbounded_Text_Type;
- -- A short description of the error
-
- Property_Error_Info : Exception_Occurrence_Access := null;
- -- If the raised error encapsulates a property error, this will
- -- contain an access to the property error exception occurence.
- -- Else, will be null.
- end case;
- end record;
- -- Store an error value.
-
- function Error_Description (Error : Error_Data) return Unbounded_Text_Type;
- -- Return a detailed description of the given error.
-
- function Is_Error (Err : Error_Data) return Boolean;
- -- Return whether Err contains an error
-
- function Make_Empty_Error return Error_Data;
-
- function Make_Eval_Error
- (AST_Node : L.Lkql_Node'Class;
- Short_Message : Text_Type;
- Property_Error_Info : Exception_Occurrence_Access := null)
- return Error_Data;
- -- Create an error value of kind Eval_Error
-
-end LKQL.Errors;
diff --git a/lkql/extensions/src/lkql-eval_contexts.adb b/lkql/extensions/src/lkql-eval_contexts.adb
deleted file mode 100644
index 862599d82..000000000
--- a/lkql/extensions/src/lkql-eval_contexts.adb
+++ /dev/null
@@ -1,632 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Environment_Variables;
-with Ada.Directories;
-with Ada.Strings.Wide_Wide_Unbounded; use Ada.Strings.Wide_Wide_Unbounded;
-
-with GNAT.OS_Lib;
-with GNATCOLL.Utils;
-
-with Liblkqllang.Prelude; use Liblkqllang.Prelude;
-
-with LKQL.Evaluation; use LKQL.Evaluation;
-with LKQL.Builtin_Functions; use LKQL.Builtin_Functions;
-with LKQL.String_Utils; use LKQL.String_Utils;
-with LKQL.Unit_Utils; use LKQL.Unit_Utils;
-with LKQL.Error_Handling; use LKQL.Error_Handling;
-
-package body LKQL.Eval_Contexts is
-
- procedure Free_Environment (Self : in out Environment_Access);
-
- procedure Free_Lk_Node_Array
- is new Ada.Unchecked_Deallocation
- (LK.Lk_Node_Array, Lk_Node_Array_Access);
-
- ----------------------
- -- Free_Environment --
- ----------------------
-
- procedure Free_Environment (Self : in out Environment_Access) is
- procedure Free is new Ada.Unchecked_Deallocation
- (Environment, Environment_Access);
- begin
- -- Give up the reference we have on the parent env.
- Dec_Ref (Self.Parent);
-
- -- If this environment owns a memory pool, release it.
- if Self.Pools /= null
- and then Self.Is_Pools_Owner
- then
- Destroy (Self.Pools);
- end if;
- Free (Self);
- end Free_Environment;
-
- ---------------
- -- Add_Error --
- ---------------
-
- procedure Add_Error (Ctx : Eval_Context; Error : Error_Data) is
- begin
- Ctx.Kernel.Last_Error := Error;
- end Add_Error;
-
- ---------------------------
- -- Release_Current_Frame --
- ---------------------------
-
- procedure Release_Current_Frame (Ctx : in out Eval_Context) is
- begin
- Dec_Ref (Ctx.Frames);
- end Release_Current_Frame;
-
- ----------------
- -- Last_Error --
- ----------------
-
- function Last_Error (Ctx : Eval_Context) return Error_Data is
- (Ctx.Kernel.Last_Error);
-
- -------------------------------
- -- Attach_Node_To_Last_Error --
- -------------------------------
-
- procedure Attach_Node_To_Last_Error
- (Ctx : Eval_Context; Node : L.Lkql_Node) is
- begin
- Ctx.Kernel.Last_Error.AST_Node := Node;
- end Attach_Node_To_Last_Error;
-
- -------------------------
- -- Exists_In_Local_Env --
- -------------------------
-
- function Exists_In_Local_Env (Ctx : Eval_Context;
- Key : Symbol_Type) return Boolean
- is (Ctx.Frames.Local_Bindings.Contains (Key));
-
- ---------------
- -- AST_Roots --
- ---------------
-
- function AST_Roots (Ctx : Eval_Context) return Lk_Node_Array_Access is
- (Ctx.Kernel.Ast_Roots);
-
- -------------------
- -- Set_AST_Roots --
- -------------------
-
- procedure Set_Units
- (Ctx : Eval_Context;
- Units : LK_Unit_Array)
- is
- begin
- Free_Lk_Node_Array (Ctx.Kernel.Ast_Roots);
-
- Ctx.Kernel.Ast_Roots :=
- new LK.Lk_Node_Array (Units'Range);
-
- for J in Ctx.Kernel.Ast_Roots'Range loop
- Ctx.Kernel.Ast_Roots (J) := Units (J).Root;
- end loop;
- end Set_Units;
-
- -----------
- -- Clone --
- -----------
-
- function Ref_Frame (Ctx : Eval_Context) return Eval_Context is
- begin
- Inc_Ref (Ctx.Frames);
- return Ctx;
- end Ref_Frame;
-
- ----------------------
- -- Create_New_Frame --
- ----------------------
-
- function Create_New_Frame
- (Ctx : Eval_Context;
- Local_Bindings : Environment_Map := Empty_Map) return Eval_Context
- is
- New_Env : constant Environment_Access :=
- new Environment'
- (Local_Bindings => Local_Bindings,
- Parent => Ctx.Frames,
- Ref_Count => <>,
- Pools => Ctx.Pools,
- Is_Pools_Owner => False);
- begin
- -- The new env holds a reference to its parent, so increment the
- -- reference count.
- Inc_Ref (New_Env.Parent);
-
- return Eval_Context'(Ctx.Kernel, New_Env);
- end Create_New_Frame;
-
- ------------
- -- Lookup --
- ------------
-
- function Lookup (Ctx : Eval_Context;
- Key : Symbol_Type) return String_Value_Maps.Cursor
- is (Lookup (Ctx.Frames.all, Key));
-
- -----------------
- -- Add_Binding --
- -----------------
-
- procedure Add_Binding (Ctx : Eval_Context;
- Key : Text_Type;
- Value : Primitive)
- is
- begin
- Add_Binding
- (Ctx, Find (Ctx.Kernel.Context.Get_Symbol_Table, Key), Value);
- end Add_Binding;
-
- -----------------
- -- Add_Binding --
- -----------------
-
- procedure Add_Binding (Ctx : Eval_Context;
- Key : Symbol_Type;
- Value : Primitive)
- is
- begin
- Ctx.Frames.Local_Bindings.Include (Key, Value);
- end Add_Binding;
-
- ---------------------
- -- Is_Root_Context --
- ---------------------
-
- function Is_Root_Context (Ctx : Eval_Context) return Boolean is
- (Ctx.Frames.Parent = null);
-
- --------------------
- -- Parent_Context --
- --------------------
-
- function Parent_Context (Ctx : Eval_Context) return Eval_Context is
- Parent_Env : constant Environment_Access :=
- Ctx.Frames.Parent;
- begin
- return Eval_Context'(Ctx.Kernel, Parent_Env);
- end Parent_Context;
-
- -----------------------
- -- Make_Eval_Context --
- -----------------------
-
- function Make_Eval_Context
- (Ast_Roots : LK.Lk_Node_Array;
- Lang_Id : Langkit_Support.Generic_API.Language_Id;
- Analysis_Ctx : L.Analysis_Context := L.No_Analysis_Context)
- return Eval_Context
- is
- use L;
-
- Roots : constant Lk_Node_Array_Access :=
- new Lk_Node_Array'(Ast_Roots);
- Kernel : constant Global_Data_Access :=
- new Global_Data'
- (Roots, Make_Empty_Error,
- (if Analysis_Ctx = L.No_Analysis_Context
- then L.Create_Context
- else Analysis_Ctx),
- Lkql_Path_List => <>,
- Builtin_Methods => <>,
- Lang_Id => Lang_Id,
- Name_Map => null);
- Env : constant Environment_Access :=
- new Environment'(Make_Empty_Environment (Create_Pool => True));
- Ret : Eval_Context := Eval_Context'(Kernel, Env);
-
- package E renames Ada.Environment_Variables;
- begin
- -- Adding Ada built-in functions + prelude to the context.
- declare
- U : constant L.Analysis_Unit := Prelude_Unit (Ret);
-
- Dummy : constant Primitive := Eval (Ret, U.Root);
- begin
- for Fn_Desc of Builtin_Functions.All_Builtins loop
-
- -- Add bindings to the toplevel scope, if the function is not
- -- marked as being accessible only via dot notation calls on
- -- objects.
- if not Fn_Desc.Only_Dot_Calls then
- Ret.Add_Binding
- (To_Text (Fn_Desc.Name),
- Make_Builtin_Function (Fn_Desc, Ret.Pool));
- end if;
-
- -- For applicable functions, register them in the builtin
- -- properties table, which will allow them to be called via
- -- the dot notation on objects.
- if Fn_Desc.Params'Length > 0 then
- declare
- Name : constant Symbol_Type := Find
- (Kernel.Context.Get_Symbol_Table,
- To_Text (Fn_Desc.Name));
- begin
- Kernel.Builtin_Methods.Include
- ((Fn_Desc.Params (1).Expected_Kind, Name),
- Fn_Desc);
- end;
- end if;
- end loop;
- end;
-
- -- Set up LKQL_PATH for the context
- if E.Exists ("LKQL_PATH") then
- declare
- function Add_Path (Path : String) return Boolean;
-
- Lkql_Path_Content : constant String := E.Value ("LKQL_PATH");
-
- function Add_Path (Path : String) return Boolean is
- begin
- Add_Lkql_Path (Ret, Path);
- return True;
- end Add_Path;
- begin
- GNATCOLL.Utils.Split
- (Lkql_Path_Content,
- GNAT.OS_Lib.Path_Separator & "",
- Add_Path'Access);
- end;
- end if;
-
- return Ret;
- end Make_Eval_Context;
-
- -----------------------
- -- Free_Eval_Context --
- -----------------------
-
- procedure Free_Eval_Context (Ctx : in out Eval_Context) is
- begin
- pragma Assert (Ctx.Frames.Parent = null,
- "Cannot free a non-root evaluation context");
-
- Free_Lk_Node_Array (Ctx.Kernel.Ast_Roots);
- Free_Environment (Ctx.Frames);
- Free_Global_Data (Ctx.Kernel);
- end Free_Eval_Context;
-
- ------------
- -- Lookup --
- ------------
-
- function Lookup
- (Env : Environment;
- Key : Symbol_Type;
- Local : Boolean := False) return String_Value_Maps.Cursor
- is
- Lookup_Result : constant Cursor := Env.Local_Bindings.Find (Key);
- begin
- if not Has_Element (Lookup_Result)
- and then not Local and then Env.Parent /= null
- then
- return Lookup (Env.Parent.all, Key);
- end if;
-
- return Lookup_Result;
- end Lookup;
-
- ----------------------------
- -- Make_Empty_Environment --
- ----------------------------
-
- function Make_Empty_Environment
- (Parent : Environment_Access := null;
- Create_Pool : Boolean := False) return Environment
- is
- begin
- return Environment'
- (String_Value_Maps.Empty_Map,
- Parent,
- Ref_Count => 1,
- Pools => (if Create_Pool then Create else null),
- Is_Pools_Owner => Create_Pool);
- end Make_Empty_Environment;
-
- ------------------
- -- Add_Bindings --
- ------------------
-
- procedure Add_Bindings
- (Env : in out Environment_Map; New_Bindings : Environment_Map)
- is
- begin
- for C in Iterate (New_Bindings) loop
- Env.Include (Key (C), Element (C));
- end loop;
- end Add_Bindings;
-
- -------------
- -- Inc_Ref --
- -------------
-
- procedure Inc_Ref (Self : Environment_Access) is
- begin
- Self.Ref_Count := Self.Ref_Count + 1;
- end Inc_Ref;
-
- -----------------
- -- Get_Context --
- -----------------
-
- function Get_Context (Self : Global_Data) return L.Analysis_Context is
- begin
- return Self.Context;
- end Get_Context;
-
- -------------------------
- -- Get_Builtin_Methods --
- -------------------------
-
- function Get_Builtin_Methods
- (Self : Global_Data_Access) return Builtin_Methods_Map_Access is
- begin
- return Self.Builtin_Methods'Unrestricted_Access;
- end Get_Builtin_Methods;
-
- ------------------
- -- Get_Name_Map --
- ------------------
-
- function Get_Name_Map (Ctx : Eval_Context) return Name_Map_Access is
- begin
- if Ctx.Kernel.Name_Map = null then
- Ctx.Kernel.Name_Map := new LKI.Name_Map'
- (LKI.Create_Name_Map
- (Ctx.Kernel.Lang_Id,
- Ctx.Kernel.Context.Get_Symbol_Table,
- LKN.Camel, LKN.Lower, LKN.Camel, LKN.Lower));
- end if;
-
- return Ctx.Kernel.Name_Map;
- end Get_Name_Map;
-
- -------------
- -- Dec_Ref --
- -------------
-
- procedure Dec_Ref (Self : in out Environment_Access) is
- begin
- if Self /= null then
- -- TODO U315-023: Because of the fact that we have non-handled cycles
- -- in the environments, due to closures, package level finalization
- -- will try to free those cycles and might reach a point where this
- -- is called twice in a cycle, so Ref_Count is already equal to zero.
- -- In those cases, just no-op.
- if Self.Ref_Count > 0 then
- Self.Ref_Count := Self.Ref_Count - 1;
-
- if Self.Ref_Count = 0 then
- Free_Environment (Self);
- end if;
- end if;
- end if;
- end Dec_Ref;
-
- ---------------
- -- Env_Image --
- ---------------
-
- function Env_Image (Env : Environment_Access) return String is
- begin
- return ". --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Vectors;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-
-with LKQL.Errors; use LKQL.Errors;
-with LKQL.Primitives; use LKQL.Primitives;
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-with Ada.Containers.Hashed_Maps;
-with Ada.Unchecked_Deallocation;
-with Ada.Containers; use Ada.Containers;
-
-package LKQL.Eval_Contexts is
-
- type Lk_Node_Array_Access is access all LK.Lk_Node_Array;
-
- type LK_Unit_Array is array (Positive range <>) of LK.Lk_Unit;
-
- package String_Value_Maps is new Ada.Containers.Hashed_Maps
- (Key_Type => Symbol_Type,
- Element_Type => Primitive,
- Hash => Hash,
- Equivalent_Keys => "=");
- use String_Value_Maps;
-
- subtype Environment_Map is String_Value_Maps.Map;
-
- procedure Add_Bindings
- (Env : in out Environment_Map; New_Bindings : Environment_Map);
- -- Add the key-value pairs from 'New_Bindings' to 'Env'
-
- type Global_Data is private;
-
- type Global_Data_Access is access all Global_Data;
-
- function Get_Context (Self : Global_Data) return L.Analysis_Context;
-
- type Environment is private;
-
- function Lookup (Env : Environment;
- Key : Symbol_Type;
- Local : Boolean := False) return String_Value_Maps.Cursor;
- -- Lookup the given key in the local environment.
- -- If the local environment doesn't contain the given key, and ``Local`` is
- -- False, the lookup will be attempted on the parent env,
- -- if any.
-
- type Environment_Access is access all Environment;
-
- procedure Inc_Ref (Self : Environment_Access);
- procedure Dec_Ref (Self : in out Environment_Access);
- function Env_Map_Image (Self : Environment_Map) return String;
-
- function Get_Env_Map (Self : Environment_Access) return Environment_Map;
- -- Get the env map for this env.
-
- function Get_Parent (Self : Environment_Access) return Environment_Access;
- -- Get the parent env for this env.
-
- function Get_Pools (Self : Environment_Access) return Primitive_Pool_Stack;
-
- function Env_Image (Env : Environment_Access) return String;
- -- Return a structured debug image of the env passed in parameter.
-
- type Builtin_Method_Descriptor is record
- Expected_Kind : Base_Primitive_Kind;
- -- Kind expected for the self argument of the method
-
- Name : Symbol_Type;
- -- Name of the method
- end record;
-
- function Hash
- (Self : Builtin_Method_Descriptor) return Hash_Type
- is
- (Hash (Self.Name));
-
- function Eq_Keys (L, R : Builtin_Method_Descriptor) return Boolean
- is
- (L.Name = R.Name
- and then
- (L.Expected_Kind = No_Kind
- or else R.Expected_Kind = No_Kind
- or else L.Expected_Kind = R.Expected_Kind));
-
- package Builtin_Methods_Maps is new Ada.Containers.Hashed_Maps
- (Key_Type => Builtin_Method_Descriptor,
- Element_Type => Builtin_Function,
- Hash => Hash,
- Equivalent_Keys => Eq_Keys,
- "=" => "=");
-
- type Builtin_Methods_Map is new Builtin_Methods_Maps.Map with null record;
- type Builtin_Methods_Map_Access is access all Builtin_Methods_Map;
-
- function Get_Builtin_Methods
- (Self : Global_Data_Access) return Builtin_Methods_Map_Access;
- -- Return a map of ``(name, kind) -> Builtin_Method_Descriptor``
-
- type Name_Map_Access is access all LKI.Name_Map;
-
- ------------------
- -- Eval_Context --
- ------------------
-
- type Eval_Context is tagged record
- Kernel : Global_Data_Access;
- -- Global structured shared by every Eval_Context instance
-
- Frames : Environment_Access;
- -- Chain of environments from the local frame to the global env
- end record;
- -- Store the evaluation context.
-
- function Get_Name_Map (Ctx : Eval_Context) return Name_Map_Access;
- -- Return a Name_Map for the target language.
-
- function Pools (Ctx : Eval_Context) return Primitive_Pool_Stack;
- -- Return the primitive pool associated with this context
-
- function Pool (Ctx : Eval_Context) return Primitive_Pool;
- -- Return the primitive pool associated with this context
-
- function Symbol (Ctx : Eval_Context; Str : Text_Type) return Symbol_Type;
- -- Get a symbol from this context's symbol table
-
- procedure Add_Error (Ctx : Eval_Context; Error : Error_Data);
- -- Add the given error to the evaluation context.
-
- procedure Release_Current_Frame (Ctx : in out Eval_Context);
- -- Free the memory allocated for the local frame.
-
- function Last_Error (Ctx : Eval_Context) return Error_Data;
- -- Return the value of the last registered error
-
- procedure Attach_Node_To_Last_Error
- (Ctx : Eval_Context; Node : L.Lkql_Node);
- -- Attach given node to the last error
-
- function Exists_In_Local_Env (Ctx : Eval_Context;
- Key : Symbol_Type) return Boolean;
- -- Return whether the given name is associated to a value in the local
- -- environment.
-
- function AST_Roots (Ctx : Eval_Context) return Lk_Node_Array_Access;
- -- Return the evaluation context's AST root
-
- procedure Set_Units
- (Ctx : Eval_Context;
- Units : LK_Unit_Array);
- -- Set the units of a given Ctx
-
- function Ref_Frame (Ctx : Eval_Context) return Eval_Context;
- -- Increase the reference counter of the context and return it
-
- function Create_New_Frame
- (Ctx : Eval_Context;
- Local_Bindings : Environment_Map := Empty_Map) return Eval_Context;
- -- Create a new evaluation context with the current environment as parent
- -- environment.
- -- If the bindings from 'Local_Bindings' will be added to the local
- -- environment.
-
- function Lookup (Ctx : Eval_Context;
- Key : Symbol_Type) return String_Value_Maps.Cursor;
- -- Return a cursor to the element associated with the given key in the
- -- evaluation context's frames.
-
- procedure Add_Binding (Ctx : Eval_Context;
- Key : Symbol_Type;
- Value : Primitive);
- procedure Add_Binding (Ctx : Eval_Context;
- Key : Text_Type;
- Value : Primitive);
- -- Associate 'Value' to the given key in the local frame.
-
- function Is_Root_Context (Ctx : Eval_Context) return Boolean;
- -- Return whether the current context is the root context. I.e, it's
- -- environment doesn't have a parent environment.
-
- function Parent_Context (Ctx : Eval_Context) return Eval_Context
- with Pre => not Ctx.Is_Root_Context;
- -- Return the parent of the current local context.
- -- An Assertion_Error will be raised is 'Ctx' is the root context.
-
- function Make_Eval_Context
- (Ast_Roots : LK.Lk_Node_Array;
- Lang_Id : Langkit_Support.Generic_API.Language_Id;
- Analysis_Ctx : L.Analysis_Context := L.No_Analysis_Context)
- return Eval_Context;
- -- Create a new Eval_Context with the given Ast_Root and error recovery
- -- flag. If passed an analysis context, use this instead of creating one.
-
- function Lang_Id
- (Ctx : Eval_Context) return Langkit_Support.Generic_API.Language_Id;
-
- procedure Free_Eval_Context (Ctx : in out Eval_Context);
- -- Release the memory allocated for the evaluation context.
- -- Raise an assertion error if Ctx is not the root context.
- -- Use Release_Local_Frame to release the memory allocated for a local
- -- environment.
-
- function Get_Lkql_Unit
- (Ctx : Eval_Context;
- Package_Name : String;
- From : L.Analysis_Unit := L.No_Analysis_Unit)
- return L.Analysis_Unit;
- -- Get a LKQL unit, searching on the context's LKQL_PATH
-
- procedure Add_Lkql_Path (Ctx : in out Eval_Context; Path : String);
- -- Add a path to the LKQL_PATH
-
- procedure Raise_Error
- (Ctx : Eval_Context;
- N : L.Lkql_Node'Class;
- Err : Text_Type) with No_Return;
- -- Raise an error with given error message
-
-private
-
- package String_Vectors
- is new Ada.Containers.Vectors (Positive, Unbounded_String);
-
- -----------------
- -- Global_Data --
- -----------------
-
- type Global_Data is record
- Ast_Roots : Lk_Node_Array_Access;
- -- Root node for each libadalang analysis unit that will be analysed in
- -- the context.
-
- Last_Error : Error_Data := Make_Empty_Error;
- -- Store data about the last error, if any.
-
- Context : L.Analysis_Context;
- -- LKQL analysis context, used to hold data of the prelude
-
- Lkql_Path_List : String_Vectors.Vector;
-
- Builtin_Methods : Builtin_Methods_Map;
- -- Map of builtin methods by (self_kind, name)
-
- Lang_Id : Langkit_Support.Generic_API.Language_Id;
- -- Language_Id for the target language
-
- Name_Map : Name_Map_Access;
- end record;
- -- Stores the global data structures shared by every evaluation context
-
- procedure Free_Global_Data is new Ada.Unchecked_Deallocation
- (Global_Data, Global_Data_Access);
-
- -----------------
- -- Environment --
- -----------------
-
- type Environment is record
- Local_Bindings : Environment_Map;
- -- Map containing the local
-
- Parent : Environment_Access;
- -- Parent environment
- -- If this environment is non-null, it will be used as a fallback upon
- -- lookup failures.
-
- Ref_Count : Natural := 1;
-
- Pools : Primitive_Pool_Stack;
- -- Pool in which to allocate data for primitives in this scope
-
- Is_Pools_Owner : Boolean := False;
- -- Whether this env is the owner of its pool or not
- end record;
- -- Chainable map for symbol lookups
-
- function Make_Empty_Environment
- (Parent : Environment_Access := null;
- Create_Pool : Boolean := False) return Environment;
- -- Return an empty map from Unbounded_Text_Type to Primitive values
-
-end LKQL.Eval_Contexts;
diff --git a/lkql/extensions/src/lkql-evaluation.adb b/lkql/extensions/src/lkql-evaluation.adb
deleted file mode 100644
index bd0f303da..000000000
--- a/lkql/extensions/src/lkql-evaluation.adb
+++ /dev/null
@@ -1,1295 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Assertions; use Ada.Assertions;
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-with LKQL.Errors; use LKQL.Errors;
-with LKQL.Queries; use LKQL.Queries;
-with LKQL.Patterns; use LKQL.Patterns;
-with LKQL.Functions; use LKQL.Functions;
-with LKQL.Node_Data;
-with LKQL.Patterns.Match; use LKQL.Patterns.Match;
-with LKQL.Error_Handling; use LKQL.Error_Handling;
-with LKQL.Adaptive_Integers; use LKQL.Adaptive_Integers;
-with LKQL.Node_Extensions; use LKQL.Node_Extensions;
-with LKQL.Lk_Nodes_Iterators; use LKQL.Lk_Nodes_Iterators;
-
-package body LKQL.Evaluation is
-
- use all type Unbounded_Text_Type;
-
- function Eval_List
- (Ctx : Eval_Context; Node : L.Lkql_Node_List) return Primitive;
-
- function Eval_Val_Decl
- (Ctx : Eval_Context; Node : L.Val_Decl) return Primitive;
-
- function Eval_Fun_Decl
- (Ctx : Eval_Context; Node : L.Fun_Decl) return Primitive;
-
- function Eval_Selector_Decl
- (Ctx : Eval_Context; Node : L.Selector_Decl) return Primitive;
-
- function Eval_Fun_Expr
- (Ctx : Eval_Context;
- Node : L.Base_Function;
- With_Call_Cache : Boolean := False) return Primitive;
-
- function Eval_Identifier
- (Ctx : Eval_Context; Node : L.Identifier) return Primitive;
-
- function Eval_Tuple (Ctx : Eval_Context; Node : L.Tuple) return Primitive;
-
- function Eval_Bool_Literal (Node : L.Bool_Literal) return Primitive;
-
- function Eval_Unit_Literal (Node : L.Unit_Literal) return Primitive;
-
- function Eval_If_Then_Else
- (Ctx : Eval_Context; Node : L.If_Then_Else) return Primitive;
-
- function Eval_Bin_Op
- (Ctx : Eval_Context; Node : L.Bin_Op) return Primitive;
-
- function Eval_Un_Op
- (Ctx : Eval_Context; Node : L.Un_Op) return Primitive;
-
- function Eval_Non_Short_Circuit_Op
- (Ctx : Eval_Context; Node : L.Bin_Op) return Primitive;
-
- function Eval_Short_Circuit_Op
- (Ctx : Eval_Context; Node : L.Bin_Op) return Primitive;
-
- function Eval_Dot_Access
- (Ctx : Eval_Context; Node : L.Dot_Access) return Primitive;
-
- function Eval_Safe_Access
- (Ctx : Eval_Context; Node : L.Safe_Access) return Primitive;
-
- function Eval_Is
- (Ctx : Eval_Context; Node : L.Is_Clause) return Primitive;
-
- function Eval_In
- (Ctx : Eval_Context; Node : L.In_Clause) return Primitive;
-
- function Eval_Query
- (Ctx : Eval_Context; Node : L.Query) return Primitive;
-
- function Eval_Indexing
- (Ctx : Eval_Context; Node : L.Indexing) return Primitive;
-
- function Eval_List_Comprehension
- (Ctx : Eval_Context; Node : L.List_Comprehension) return Primitive;
-
- function Eval_Block_Expr
- (Ctx : Eval_Context; Node : L.Block_Expr) return Primitive;
-
- function Eval_Body_Decl
- (Ctx : Eval_Context; Node : L.Block_Body_Decl) return Primitive;
-
- function Eval_Body_Expr
- (Ctx : Eval_Context; Node : L.Block_Body_Expr) return Primitive;
-
- function Eval_List_Literal
- (Ctx : Eval_Context; Node : L.List_Literal) return Primitive;
-
- function Eval_Object_Literal
- (Ctx : Eval_Context; Node : L.Object_Literal) return Primitive;
-
- function Eval_At_Object_Literal
- (Ctx : Eval_Context; Node : L.At_Object_Literal) return Primitive;
-
- function Eval_Match (Ctx : Eval_Context; Node : L.Match) return Primitive;
-
- function Eval_Unwrap (Ctx : Eval_Context; Node : L.Unwrap) return Primitive;
-
- function Eval_Import
- (Ctx : Eval_Context; Node : L.Import) return Primitive;
-
- function Make_Comprehension_Environment_Iter
- (Ctx : Eval_Context; Node : L.List_Comp_Assoc_List)
- return Comprehension_Env_Iter;
- -- Given a List of Arrow_Assoc, return an iterator that yields the
- -- environments produced by this list of Arrow_Assoc in the context of a
- -- list comprehension.
-
- function Get_Truthy (Ctx : Eval_Context;
- Node : L.Lkql_Node;
- Value : Primitive)
- return Primitive;
- -- Given a primitive, returns its truthy value if it has one.
- -- Raise an exception and register an error in the evaluation context if
- -- the primitive has no truthy value.
-
- ----------------
- -- Get_Truthy --
- ----------------
-
- function Get_Truthy (Ctx : Eval_Context;
- Node : L.Lkql_Node;
- Value : Primitive)
- return Primitive
- is
- Has_Truthy : Boolean;
- Truthy_Value : constant Boolean := Truthy (Value, Has_Truthy);
- begin
- if Has_Truthy then
- return To_Primitive (Truthy_Value);
- else
- Raise_Invalid_Kind (Ctx, Node, Kind_Bool, Value);
- end if;
- end Get_Truthy;
-
- ----------------
- -- Check_Kind --
- ----------------
-
- procedure Check_Kind (Ctx : Eval_Context;
- Node : L.Lkql_Node;
- Expected_Kind : Valid_Primitive_Kind;
- Value : Primitive)
- is
- begin
- if Kind (Value) /= Expected_Kind then
- Raise_Invalid_Kind (Ctx, Node, Expected_Kind, Value);
- end if;
- end Check_Kind;
-
- ----------
- -- Eval --
- ----------
-
- function Eval (Ctx : Eval_Context;
- Node : L.Lkql_Node'Class;
- Expected_Kind : Base_Primitive_Kind := No_Kind;
- Local_Bindings : Environment_Map :=
- String_Value_Maps.Empty_Map)
- return Primitive
- is
- Result : Primitive;
- Local_Context : Eval_Context :=
- (if Local_Bindings.Is_Empty then Ctx
- else Ctx.Create_New_Frame (Local_Bindings));
- begin
-
- case Node.Kind is
- when LCO.Lkql_Lkql_Node_List =>
- Result := Eval_List (Local_Context, Node.As_Lkql_Node_List);
- when LCO.Lkql_Val_Decl =>
- Result := Eval_Val_Decl (Local_Context, Node.As_Val_Decl);
-
- when LCO.Lkql_Import =>
- Result := Eval_Import (Local_Context, Node.As_Import);
- when LCO.Lkql_Identifier =>
- Result := Eval_Identifier (Local_Context, Node.As_Identifier);
- when LCO.Lkql_Integer_Literal =>
- Result := To_Primitive
- (Adaptive_Integers.Create (To_UTF8 (Node.Text)),
- Local_Context.Pool);
- when LCO.Lkql_Tuple =>
- Result := Eval_Tuple (Local_Context, Node.As_Tuple);
- when LCO.Lkql_String_Literal | LCO.Lkql_Block_String_Literal =>
- Result := To_Primitive
- (Get_Ext (Node).Content.Denoted_Value.all, Local_Context.Pool);
- when LCO.Lkql_Bool_Literal =>
- Result := Eval_Bool_Literal (Node.As_Bool_Literal);
- when LCO.Lkql_Unit_Literal =>
- Result := Eval_Unit_Literal (Node.As_Unit_Literal);
- when LCO.Lkql_If_Then_Else =>
- Result := Eval_If_Then_Else (Local_Context, Node.As_If_Then_Else);
- when LCO.Lkql_Bin_Op_Range =>
- Result := Eval_Bin_Op (Local_Context, Node.As_Bin_Op);
- when LCO.Lkql_Un_Op_Range =>
- Result := Eval_Un_Op (Local_Context, Node.As_Un_Op);
- when LCO.Lkql_Dot_Access =>
- Result := Eval_Dot_Access (Local_Context, Node.As_Dot_Access);
- when LCO.Lkql_Safe_Access =>
- Result := Eval_Safe_Access (Local_Context, Node.As_Safe_Access);
- when LCO.Lkql_Is_Clause =>
- Result := Eval_Is (Local_Context, Node.As_Is_Clause);
- when LCO.Lkql_In_Clause =>
- Result := Eval_In (Local_Context, Node.As_In_Clause);
- when LCO.Lkql_Query =>
- Result := Eval_Query (Local_Context, Node.As_Query);
- when LCO.Lkql_Indexing | LCO.Lkql_Safe_Indexing =>
- Result := Eval_Indexing (Local_Context, Node.As_Indexing);
- when LCO.Lkql_List_Comprehension =>
- Result := Eval_List_Comprehension
- (Local_Context, Node.As_List_Comprehension);
- when LCO.Lkql_Block_Expr =>
- Result := Eval_Block_Expr (Local_Context, Node.As_Block_Expr);
- when LCO.Lkql_Block_Body_Decl =>
- Result :=
- Eval_Body_Decl (Local_Context, Node.As_Block_Body_Decl);
- when LCO.Lkql_Block_Body_Expr =>
- Result :=
- Eval_Body_Expr (Local_Context, Node.As_Block_Body_Expr);
- when LCO.Lkql_Fun_Decl =>
- Result := Eval_Fun_Decl (Local_Context, Node.As_Fun_Decl);
- when LCO.Lkql_Selector_Decl =>
- Result :=
- Eval_Selector_Decl (Local_Context, Node.As_Selector_Decl);
- when LCO.Lkql_Anonymous_Function =>
- Result := Eval_Fun_Expr (Local_Context, Node.As_Base_Function);
- when LCO.Lkql_Fun_Call =>
- Result := Eval_Call (Local_Context, Node.As_Fun_Call);
- when LCO.Lkql_Match =>
- Result := Eval_Match (Local_Context, Node.As_Match);
- when LCO.Lkql_Unwrap =>
- Result := Eval_Unwrap (Local_Context, Node.As_Unwrap);
- when LCO.Lkql_Null_Literal =>
- Result := To_Primitive (LK.No_Lk_Node, Local_Context.Pool);
- when LCO.Lkql_List_Literal =>
- Result := Eval_List_Literal (Local_Context, Node.As_List_Literal);
- when LCO.Lkql_Object_Literal =>
- Result := Eval_Object_Literal
- (Local_Context, Node.As_Object_Literal);
- when LCO.Lkql_At_Object_Literal =>
- Result := Eval_At_Object_Literal
- (Local_Context, Node.As_At_Object_Literal);
- when others =>
- raise Assertion_Error
- with "Invalid evaluation root kind: " & Node.Kind_Name;
- end case;
-
- if Expected_Kind = Kind_Bool then
- Result := Get_Truthy (Local_Context, Node.As_Lkql_Node, Result);
- elsif Expected_Kind in Valid_Primitive_Kind then
- Check_Kind (Local_Context, Node.As_Lkql_Node, Expected_Kind, Result);
- end if;
-
- if Local_Context /= Ctx then
- Local_Context.Release_Current_Frame;
- end if;
-
- return Result;
-
- exception
- when Stop_Evaluation_Error =>
- pragma Assert
- (Is_Error (Ctx.Last_Error),
- "Stop Evaluation Error raised without adding the "
- & "error to the evaluation context");
-
- if Ctx.Last_Error.AST_Node.Is_Null then
- Ctx.Attach_Node_To_Last_Error (Node.As_Lkql_Node);
- end if;
-
- if Local_Context /= Ctx then
- Local_Context.Release_Current_Frame;
- end if;
-
- raise;
- when others =>
- if Local_Context /= Ctx then
- Local_Context.Release_Current_Frame;
- end if;
-
- raise;
- end Eval;
-
- ---------------
- -- Eval_List --
- ---------------
-
- function Eval_List
- (Ctx : Eval_Context; Node : L.Lkql_Node_List) return Primitive
- is
- Result : Primitive;
- begin
- if Node.Children'Length = 0 then
- return Make_Unit_Primitive;
- end if;
-
- for Child of Node.Children loop
- begin
- Result := Eval (Ctx, Child);
- end;
- end loop;
-
- return Result;
- end Eval_List;
-
- -------------------
- -- Eval_Val_Decl --
- -------------------
-
- function Eval_Val_Decl
- (Ctx : Eval_Context; Node : L.Val_Decl) return Primitive
- is
- Identifier : constant Symbol_Type := Symbol (Node.F_Identifier);
- begin
- if Ctx.Exists_In_Local_Env (Identifier) then
- Raise_Already_Existing_Symbol (Ctx,
- Identifier,
- Node.F_Identifier.As_Lkql_Node);
- end if;
-
- Ctx.Add_Binding (Identifier, Eval (Ctx, Node.F_Value));
- return Make_Unit_Primitive;
- end Eval_Val_Decl;
-
- -------------------
- -- Eval_Fun_Decl --
- -------------------
-
- function Eval_Fun_Decl
- (Ctx : Eval_Context; Node : L.Fun_Decl) return Primitive
- is
- Identifier : constant Symbol_Type := Symbol (Node.F_Name);
- begin
- if Ctx.Exists_In_Local_Env (Identifier) then
- Raise_Already_Existing_Symbol (Ctx,
- Identifier,
- Node.F_Name.As_Lkql_Node);
- end if;
-
- Ctx.Add_Binding
- (Identifier,
- Eval_Fun_Expr
- (Ctx,
- Node.F_Fun_Expr.As_Base_Function,
- With_Call_Cache =>
- not Node.F_Annotation.Is_Null
- and then Node.F_Annotation.F_Name.P_Sym = "memoized"));
-
- return Make_Unit_Primitive;
-
- end Eval_Fun_Decl;
-
- ------------------------
- -- Eval_Selector_Decl --
- ------------------------
-
- function Eval_Selector_Decl
- (Ctx : Eval_Context; Node : L.Selector_Decl) return Primitive
- is
- Identifier : constant Symbol_Type := Symbol (Node.F_Name);
- begin
- if Ctx.Exists_In_Local_Env (Identifier) then
- Raise_Already_Existing_Symbol (Ctx,
- Identifier,
- Node.F_Name.As_Lkql_Node);
- end if;
-
- -- The selector declaration will hold a reference to its original env,
- -- and can reference vars coming from it, so hold a reference on it.
- LKQL.Eval_Contexts.Inc_Ref (Ctx.Frames);
-
- Ctx.Add_Binding
- (Identifier,
- Make_Selector
- (Node, Primitives.Environment_Access (Ctx.Frames), Ctx.Pool,
- With_Call_Cache =>
- not Node.F_Annotation.Is_Null
- and then Node.F_Annotation.F_Name.P_Sym = "memoized"));
-
- return Make_Unit_Primitive;
- end Eval_Selector_Decl;
-
- -------------------
- -- Eval_Fun_Expr --
- -------------------
-
- function Eval_Fun_Expr
- (Ctx : Eval_Context;
- Node : L.Base_Function;
- With_Call_Cache : Boolean := False) return Primitive is
- begin
- -- The function will hold a reference to its original env, and can
- -- reference vars coming from it, so hold a reference on it.
- LKQL.Eval_Contexts.Inc_Ref (Ctx.Frames);
-
- return Make_Function
- (Node,
- Primitives.Environment_Access (Ctx.Frames),
- Ctx.Pool,
- With_Call_Cache => With_Call_Cache);
- end Eval_Fun_Expr;
-
- ---------------------
- -- Eval_identifier --
- ---------------------
-
- function Eval_Identifier
- (Ctx : Eval_Context; Node : L.Identifier) return Primitive
- is
- use String_Value_Maps;
- Position : constant Cursor := Ctx.Lookup (Symbol (Node));
- begin
- if Has_Element (Position) then
- return Element (Position);
- end if;
-
- Raise_Unknown_Symbol (Ctx, Node);
- end Eval_Identifier;
-
- ----------------
- -- Eval_Tuple --
- ----------------
-
- function Eval_Tuple (Ctx : Eval_Context; Node : L.Tuple) return Primitive is
- Ret : constant Primitive := Make_Empty_Tuple (Ctx.Pool);
- begin
- for Sub_Expr of Node.F_Exprs loop
- Ret.List_Val.Elements.Append (Eval (Ctx, Sub_Expr));
- end loop;
-
- return Ret;
- end Eval_Tuple;
-
- -------------------------
- -- Eval_Bool_Literal --
- -------------------------
-
- function Eval_Bool_Literal (Node : L.Bool_Literal) return Primitive is
- use type LCO.Lkql_Node_Kind_Type;
- Value : constant Boolean := (Node.Kind = LCO.Lkql_Bool_Literal_True);
- begin
- return To_Primitive (Value);
- end Eval_Bool_Literal;
-
- -----------------------
- -- Eval_Unit_Literal --
- -----------------------
-
- function Eval_Unit_Literal (Node : L.Unit_Literal) return Primitive is
- (Make_Unit_Primitive);
-
- -----------------------
- -- Eval_If_Then_Else --
- -----------------------
-
- function Eval_If_Then_Else
- (Ctx : Eval_Context; Node : L.If_Then_Else) return Primitive
- is
- Cond : constant Primitive :=
- Eval (Ctx, Node.F_Condition, Expected_Kind => Kind_Bool);
- begin
- return (if Bool_Val (Cond)
- then Eval (Ctx, Node.F_Then_Expr)
- else Eval (Ctx, Node.F_Else_Expr));
- end Eval_If_Then_Else;
-
- -----------------
- -- Eval_Bin_Op --
- -----------------
-
- function Eval_Bin_Op (Ctx : Eval_Context; Node : L.Bin_Op) return Primitive
- is
- begin
- return (case Node.F_Op.Kind is
- when LCO.Lkql_Op_And
- | LCO.Lkql_Op_Or
- =>
- Eval_Short_Circuit_Op (Ctx, Node),
- when others =>
- Eval_Non_Short_Circuit_Op (Ctx, Node));
- end Eval_Bin_Op;
-
- function Eval_Un_Op (Ctx : Eval_Context; Node : L.Un_Op) return Primitive is
- begin
- case Node.F_Op.Kind is
- when LCO.Lkql_Op_Plus =>
- return Eval (Ctx, Node.F_Operand, Kind_Int);
- when LCO.Lkql_Op_Minus =>
- return To_Primitive
- (-Int_Val (Eval (Ctx, Node.F_Operand, Kind_Int)), Ctx.Pool);
- when LCO.Lkql_Op_Not =>
- return To_Primitive
- (not Bool_Val (Eval (Ctx, Node.F_Operand, Kind_Bool)));
- when others =>
- raise Assertion_Error;
- end case;
- end Eval_Un_Op;
-
- -------------------------------
- -- Eval_Non_Short_Circuit_Op --
- -------------------------------
-
- function Eval_Non_Short_Circuit_Op
- (Ctx : Eval_Context; Node : L.Bin_Op) return Primitive
- is
- Left : constant Primitive := Eval (Ctx, Node.F_Left);
- Right : constant Primitive := Eval (Ctx, Node.F_Right);
- begin
- case Node.F_Op.Kind is
-
- when LCO.Lkql_Op_Plus =>
- Check_Kind (Ctx, Node.F_Left.As_Lkql_Node, Kind_Int, Left);
- Check_Kind (Ctx, Node.F_Right.As_Lkql_Node, Kind_Int, Right);
- return To_Primitive
- (Int_Val (Left) + Int_Val (Right), Ctx.Pool);
-
- when LCO.Lkql_Op_Minus =>
- Check_Kind (Ctx, Node.F_Left.As_Lkql_Node, Kind_Int, Left);
- Check_Kind (Ctx, Node.F_Right.As_Lkql_Node, Kind_Int, Right);
- return To_Primitive
- (Int_Val (Left) - Int_Val (Right), Ctx.Pool);
-
- when LCO.Lkql_Op_Mul =>
- Check_Kind (Ctx, Node.F_Left.As_Lkql_Node, Kind_Int, Left);
- Check_Kind (Ctx, Node.F_Right.As_Lkql_Node, Kind_Int, Right);
- return To_Primitive
- (Int_Val (Left) * Int_Val (Right), Ctx.Pool);
-
- when LCO.Lkql_Op_Div =>
- Check_Kind (Ctx, Node.F_Left.As_Lkql_Node, Kind_Int, Left);
- Check_Kind (Ctx, Node.F_Right.As_Lkql_Node, Kind_Int, Right);
- if Int_Val (Right) = Zero then
- raise Unsupported_Error with "Zero division";
- end if;
- return To_Primitive
- (Int_Val (Left) / Int_Val (Right), Ctx.Pool);
-
- when LCO.Lkql_Op_Eq =>
- return Equals (Left, Right);
- when LCO.Lkql_Op_Neq =>
- return To_Primitive (not Bool_Val (Equals (Left, Right)));
-
- when LCO.Lkql_Op_Concat => return Concat (Left, Right, Ctx.Pool);
-
- when LCO.Lkql_Op_Lt => return Lt (Left, Right);
- when LCO.Lkql_Op_Leq => return Lte (Left, Right);
- when LCO.Lkql_Op_Gt => return Gt (Left, Right);
- when LCO.Lkql_Op_Geq => return Gte (Left, Right);
- when others =>
- raise Assertion_Error with
- "Not a non-short-cirtcuit operator kind: " &
- Node.F_Op.Kind_Name;
- end case;
- exception
- when E : Unsupported_Error =>
- Raise_From_Exception (Ctx, E, Node);
- end Eval_Non_Short_Circuit_Op;
-
- ---------------------------
- -- Eval_Short_Circuit_Op --
- ---------------------------
-
- function Eval_Short_Circuit_Op
- (Ctx : Eval_Context; Node : L.Bin_Op) return Primitive
- is
- Result : Boolean;
- Left : constant L.Lkql_Node := Node.F_Left.As_Lkql_Node;
- Right : constant L.Lkql_Node := Node.F_Right.As_Lkql_Node;
-
- Left_Result : constant Boolean
- := Bool_Val (Eval (Ctx, Left, Expected_Kind => Kind_Bool));
- begin
-
- -- We eval the result of the right side expression inline to keep the
- -- operators short circuit.
-
- Result :=
- (case Node.F_Op.Kind is
- when LCO.Lkql_Op_And =>
- Left_Result and then Bool_Val (Eval
- (Ctx, Right, Expected_Kind => Kind_Bool)),
- when LCO.Lkql_Op_Or =>
- Left_Result or else Bool_Val (Eval
- (Ctx, Right, Expected_Kind => Kind_Bool)),
- when others =>
- raise Assertion_Error
- with "Not a short-circuit operator kind: "
- & Node.F_Op.Kind_Name);
- return To_Primitive (Result);
- end Eval_Short_Circuit_Op;
-
- --------------------
- -- Eval_Dot_Acess --
- --------------------
-
- function Eval_Dot_Access
- (Ctx : Eval_Context; Node : L.Dot_Access) return Primitive
- is
- Receiver : constant Primitive := Eval (Ctx, Node.F_Receiver);
- Member_Name : constant Text_Type := Node.F_Member.Text;
- begin
- declare
- Builtin_Desc : constant Builtin_Method_Descriptor :=
- (Receiver.Kind,
- Symbol (Node.F_Member));
-
- Cur : constant Builtin_Methods_Maps.Cursor :=
- Get_Builtin_Methods (Ctx.Kernel).Find (Builtin_Desc);
- use Builtin_Methods_Maps;
- begin
- -- Since this is a propertylike call to a builtin function, we filter
- -- builtin functions that have more than one argument.
- if Has_Element (Cur) and then Element (Cur).N = 1 then
- return Element (Cur).Fn_Access
- (Ctx, (1 => Receiver));
- end if;
- end;
-
- case Kind (Receiver) is
- when Kind_Object =>
- declare
- R : constant Primitive_Maps.Cursor :=
- Receiver.Obj_Assocs.Elements.Find
- (Symbol (Node.F_Member));
- begin
- if Primitive_Maps.Has_Element (R) then
- return Primitive_Maps.Element (R);
- else
- Raise_And_Record_Error
- (Ctx, Make_Eval_Error (Node, "No such member"));
- end if;
- end;
- when Kind_Node =>
- if Is_Nullish (Receiver) then
- Raise_And_Record_Error
- (Ctx, Make_Eval_Error
- (Node, "Null receiver in dot access"));
- end if;
-
- return Node_Data.Access_Node_Field
- (Ctx, Node_Val (Receiver), Node.F_Member);
-
- when Kind_Namespace =>
-
- declare
- R : constant String_Value_Maps.Cursor :=
- Lookup
- (Eval_Contexts.Environment_Access
- (Receiver.Namespace).all,
- Symbol (Node.F_Member),
- Local => True);
- begin
- if String_Value_Maps.Has_Element (R) then
- return String_Value_Maps.Element (R);
- else
- Raise_And_Record_Error
- (Ctx, Make_Eval_Error (Node, "No such member"));
- end if;
- end;
-
- when others =>
- return Primitives.Data (Receiver, Member_Name, Ctx.Pool);
- end case;
- exception
- when Unsupported_Error =>
- Raise_Invalid_Member (Ctx, Node, Receiver);
- end Eval_Dot_Access;
-
- ----------------------
- -- Eval_Safe_Access --
- ----------------------
-
- function Eval_Safe_Access
- (Ctx : Eval_Context; Node : L.Safe_Access) return Primitive
- is
- Receiver : constant LK.Lk_Node :=
- Node_Val (Eval (Ctx, Node.F_Receiver, Expected_Kind => Kind_Node));
- begin
- return (if Receiver.Is_Null
- then To_Primitive (Receiver, Ctx.Pool)
- else Node_Data.Access_Node_Field
- (Ctx, Receiver, Node.F_Member));
- end Eval_Safe_Access;
-
- -------------
- -- Eval Is --
- -------------
-
- function Eval_Is
- (Ctx : Eval_Context; Node : L.Is_Clause) return Primitive
- is
- Local_Ctx : Eval_Context := Ctx.Create_New_Frame;
- Tested_Node : constant Primitive :=
- Eval (Local_Ctx, Node.F_Node_Expr, Kind_Node);
- Success : constant Boolean :=
- Match_Pattern (Local_Ctx, Node.F_Pattern, Tested_Node).Is_Success;
- begin
- Local_Ctx.Release_Current_Frame;
- return To_Primitive (Success);
- end Eval_Is;
-
- -------------
- -- Eval_In --
- -------------
-
- function Eval_In
- (Ctx : Eval_Context; Node : L.In_Clause) return Primitive
- is
- Tested_Value : constant Primitive := Eval (Ctx, Node.F_Value_Expr);
- Tested_List : constant Primitive :=
- Eval (Ctx, Node.F_List_Expr, Kind_List);
- begin
- return To_Primitive (Contains (Tested_List, Tested_Value));
- end Eval_In;
-
- ----------------
- -- Eval_Query --
- ----------------
-
- function Eval_Query
- (Ctx : Eval_Context; Node : L.Query) return Primitive
- is
- Local_Ctx : Eval_Context := Ctx.Create_New_Frame;
- Current_Node : LK.Lk_Node;
- Iter : Lk_Node_Iterator'Class :=
- Make_Query_Iterator (Local_Ctx, Node);
- Result : Primitive;
-
- use LCO;
- begin
- if Node.F_Query_Kind.Kind = Lkql_Query_Kind_First then
- if Iter.Next (Current_Node) then
- Result := To_Primitive (Current_Node, Local_Ctx.Pool);
- else
- Result := To_Primitive (LK.No_Lk_Node, Local_Ctx.Pool);
- end if;
- else
- Result := Make_Empty_List (Local_Ctx.Pool);
-
- while Iter.Next (Current_Node) loop
- Append (Result, To_Primitive (Current_Node, Local_Ctx.Pool));
- end loop;
- end if;
-
- Iter.Release;
- Local_Ctx.Release_Current_Frame;
- return Result;
- end Eval_Query;
-
- -------------------
- -- Eval_Indexing --
- -------------------
-
- function Eval_Indexing
- (Ctx : Eval_Context; Node : L.Indexing) return Primitive
- is
- List : constant Primitive := Eval (Ctx, Node.F_Collection_Expr);
-
- use LCO;
- Raise_If_OOB : constant Boolean :=
- L.Kind (Node) /= LCO.Lkql_Safe_Indexing;
- begin
- if Kind (List) not in Kind_List | Kind_Tuple | Kind_Node | Kind_Iterator
- then
- Raise_Invalid_Type
- (Ctx, Node.As_Lkql_Node, "list, tuple, node or iterator", List);
- end if;
-
- declare
- Index : constant Integer :=
- +Int_Val (Eval (Ctx, Node.F_Index_Expr, Kind_Int));
- begin
- case Kind (List) is
- when Kind_Node =>
- return To_Primitive
- (List.Node_Val.Child (Index),
- Ctx.Pool);
-
- when Kind_Iterator =>
- declare
- Nb_Values_To_Consume : constant Natural := Integer'Max
- (Index - List.Iter_Cache.Elements.Last_Index, 0);
- begin
- Consume (List, Nb_Values_To_Consume);
- return Get (List.Iter_Cache, Index, Raise_If_OOB);
- end;
-
- when others =>
- return Get (List, Index, Raise_If_OOB);
- end case;
- end;
- exception
- when E : Unsupported_Error =>
- Raise_From_Exception (Ctx, E, Node);
- end Eval_Indexing;
-
- -----------------------------
- -- Eval_List_Comprehension --
- -----------------------------
-
- function Eval_List_Comprehension
- (Ctx : Eval_Context; Node : L.List_Comprehension) return Primitive
- is
- Comprehension_Envs : constant Comprehension_Env_Iter :=
- Make_Comprehension_Environment_Iter (Ctx, Node.F_Generators);
- Guard_Filter : constant Comprehension_Guard_Filter :=
- Make_Guard_Filter (Ctx, Node.F_Guard);
- Comprehension_Closure : constant Closure :=
- Make_Closure (Ctx, Node.F_Expr);
- Comprehension_Values : Env_Primitive_Maps.Map_Iter :=
- (if Node.F_Guard.Is_Null
- then
- Env_Primitive_Maps.Map (Comprehension_Envs, Comprehension_Closure)
- else
- Env_Primitive_Maps.Map
- (Environment_Iters.Filter (Comprehension_Envs, Guard_Filter),
- Comprehension_Closure));
- Result : constant Primitive := To_Primitive
- (Comprehension_Values, Ctx.Pool);
- begin
- Comprehension_Values.Release;
- return Result;
- end Eval_List_Comprehension;
-
- function Environment_Iter_For_Assoc
- (Ctx : Eval_Context;
- Assoc : L.List_Comp_Assoc;
- Nested : Comprehension_Env_Iter_Access)
- return Comprehension_Env_Iter_Access;
-
- ---------------------
- -- Eval_Block_Expr --
- ---------------------
-
- function Eval_Block_Expr
- (Ctx : Eval_Context; Node : L.Block_Expr) return Primitive
- is
- Local_Ctx : Eval_Context;
- Dummy : Primitive;
- begin
- -- Create a frame for the block
- Local_Ctx := Ctx.Create_New_Frame;
-
- -- Add Val_Decl bindings to the newly created frame
- for Body_Step of Node.F_Body loop
- declare
- Dummy : Primitive := Eval (Local_Ctx, Body_Step);
- begin
- null;
- end;
- end loop;
-
- -- Eval the expression in the context of the new frame, release the
- -- frame, return.
- return Ret : constant Primitive := Eval (Local_Ctx, Node.F_Expr) do
- Local_Ctx.Release_Current_Frame;
- end return;
- end Eval_Block_Expr;
-
- ----------------------
- -- Eval_Body_Decl --
- ----------------------
-
- function Eval_Body_Decl
- (Ctx : Eval_Context; Node : L.Block_Body_Decl) return Primitive is
- begin
- return Eval (Ctx, Node.F_Decl);
- end Eval_Body_Decl;
-
- ----------------------
- -- Eval_Body_Expr --
- ----------------------
-
- function Eval_Body_Expr
- (Ctx : Eval_Context; Node : L.Block_Body_Expr) return Primitive
- is
- Ret : constant Primitive := Eval (Ctx, Node.F_Expr);
- begin
- if Is_Nullish (Ret) then
- return Ret;
- end if;
-
- Raise_And_Record_Error
- (Ctx, Make_Eval_Error
- (Node, "Can't ignore the return value of an expr in a block expr"));
- end Eval_Body_Expr;
-
- ----------------
- -- Eval_Match --
- ----------------
-
- function Eval_Match (Ctx : Eval_Context; Node : L.Match) return Primitive is
- use Primitive_Options;
- Result : Primitive;
- Local_Context : Eval_Context;
- Matched_Value : constant Primitive := Eval (Ctx, Node.F_Matched_Val);
-
- begin
-
- Local_Context := Ctx.Create_New_Frame;
-
- declare
- Match_Data : constant Match_Array_Result :=
- Match_Pattern_Array (Ctx, Node.P_Patterns, Matched_Value);
- begin
-
- if Match_Data.Index = Match_Index'First then
- Local_Context.Release_Current_Frame;
- return Make_Unit_Primitive;
- end if;
-
- Local_Context.Add_Binding
- ("this", Extract (Match_Data.Matched_Value));
-
- Result :=
- Eval (Local_Context, Node.P_Nth_Expression (Match_Data.Index));
-
- Local_Context.Release_Current_Frame;
-
- return Result;
- end;
- end Eval_Match;
-
- -----------------
- -- Eval_Import --
- -----------------
-
- function Eval_Import
- (Ctx : Eval_Context; Node : L.Import) return Primitive
- is
- Package_Name : constant String := Image (Node.F_Name.Text);
- Unit : constant L.Analysis_Unit :=
- Ctx.Get_Lkql_Unit (Package_Name, From => Node.Unit);
- Frame : constant Eval_Context := Ctx.Create_New_Frame;
- Dummy : constant Primitive := Eval (Frame, Unit.Root);
- NS : constant Primitive :=
- Make_Namespace
- (Primitives.Environment_Access (Frame.Frames), Unit.Root, Ctx.Pool);
- begin
- Ctx.Add_Binding (Symbol (Node.F_Name), NS);
- return Make_Unit_Primitive;
- end Eval_Import;
-
- -----------------------
- -- Eval_List_Literal --
- -----------------------
-
- function Eval_List_Literal
- (Ctx : Eval_Context; Node : L.List_Literal) return Primitive
- is
- Res : constant Primitive := Make_Empty_List (Ctx.Pool);
- begin
- for Expr of Node.F_Exprs loop
- Res.List_Val.Elements.Append (Eval (Ctx, Expr));
- end loop;
- return Res;
- end Eval_List_Literal;
-
- -------------------------
- -- Eval_Object_Literal --
- -------------------------
-
- function Eval_Object_Literal
- (Ctx : Eval_Context; Node : L.Object_Literal) return Primitive
- is
- Res : constant Primitive := Make_Empty_Object (Ctx.Pool);
- begin
- for Assoc of Node.F_Assocs loop
- Res.Obj_Assocs.Elements.Include
- (Symbol (Assoc.F_Name), Eval (Ctx, Assoc.F_Expr));
- end loop;
- return Res;
- end Eval_Object_Literal;
-
- ----------------------------
- -- Eval_At_Object_Literal --
- ----------------------------
-
- function Eval_At_Object_Literal
- (Ctx : Eval_Context; Node : L.At_Object_Literal) return Primitive
- is
- Res : constant Primitive := Make_Empty_Object (Ctx.Pool);
- begin
- for Assoc of Node.F_Assocs loop
- Res.Obj_Assocs.Elements.Include
- (Symbol (Assoc.F_Name),
- (if Assoc.F_Expr.Is_Null
- then Make_Empty_List (Ctx.Pool)
- else Eval (Ctx, Assoc.F_Expr)));
- end loop;
- return Res;
- end Eval_At_Object_Literal;
-
- -----------------
- -- Eval_Unwrap --
- -----------------
-
- function Eval_Unwrap (Ctx : Eval_Context; Node : L.Unwrap) return Primitive
- is
- Value : constant LK.Lk_Node :=
- Node_Val (Eval (Ctx, Node.F_Node_Expr, Expected_Kind => Kind_Node));
- begin
- return To_Primitive (Value, Ctx.Pool);
- end Eval_Unwrap;
-
- -----------------------------------------
- -- Make_Comprehension_Environment_Iter --
- -----------------------------------------
-
- function Make_Comprehension_Environment_Iter
- (Ctx : Eval_Context; Node : L.List_Comp_Assoc_List)
- return Comprehension_Env_Iter
- is
- Current_Env : Comprehension_Env_Iter_Access := null;
- Res : Comprehension_Env_Iter;
- begin
- for I in reverse Node.Children'Range loop
- declare
- Current_Assoc : constant L.List_Comp_Assoc :=
- Node.Children (I).As_List_Comp_Assoc;
- begin
- Current_Env :=
- Environment_Iter_For_Assoc (Ctx, Current_Assoc, Current_Env);
- end;
- end loop;
-
- Res := Current_Env.all;
- Environment_Iters.Free_Iterator
- (Environment_Iters.Iterator_Access (Current_Env));
- return Res;
- end Make_Comprehension_Environment_Iter;
-
- --------------------------------
- -- Environment_Iter_For_Assoc --
- --------------------------------
-
- function Environment_Iter_For_Assoc
- (Ctx : Eval_Context;
- Assoc : L.List_Comp_Assoc;
- Nested : Comprehension_Env_Iter_Access)
- return Comprehension_Env_Iter_Access
- is
- use Primitive_Options;
- Generator_Value : constant Primitive :=
- Eval (Ctx, Assoc.F_Coll_Expr);
- Generator_Iter : constant Primitive_Iter_Access :=
- new Primitive_Iter'Class'(To_Iterator (Generator_Value, Ctx.Pool));
- Binding_Name : constant Symbol_Type :=
- Symbol (Assoc.F_Binding_Name);
- Nested_Resetable : constant Environment_Iters.Resetable_Access :=
- (if Nested = null then null
- else new Environment_Iters.Resetable_Iter'
- (Environment_Iters.Resetable
- (Environment_Iters.Iterator_Access (Nested))));
- Current_Element : Primitive_Options.Option;
- First_Element : Primitive;
- begin
- if Generator_Iter.Next (First_Element) then
- Current_Element := To_Option (First_Element);
- end if;
-
- return new Comprehension_Env_Iter'
- (Binding_Name, Current_Element, Generator_Iter, Nested_Resetable);
- end Environment_Iter_For_Assoc;
-
- function Update_Nested_Env (Iter : in out Comprehension_Env_Iter;
- Result : out Environment_Map) return Boolean;
- -- Return a new enviroment built by adding the current iterator's binding
- -- to the environment produced by it's 'Nested' iterator.
-
- function Create_New_Env (Iter : in out Comprehension_Env_Iter;
- Result : out Environment_Map) return Boolean;
- -- Return a new environment containing only the current iterator's binding
-
- ----------
- -- Next --
- ----------
-
- overriding function Next (Iter : in out Comprehension_Env_Iter;
- Result : out Environment_Map) return Boolean
- is
- use type Environment_Iters.Resetable_Access;
- begin
- if Iter.Nested /= null then
- return Update_Nested_Env (Iter, Result);
- else
- return Create_New_Env (Iter, Result);
- end if;
- end Next;
-
- procedure Update_Current_Element (Iter : in out Comprehension_Env_Iter);
-
- -----------------------
- -- Update_Nested_Env --
- -----------------------
-
- function Update_Nested_Env (Iter : in out Comprehension_Env_Iter;
- Result : out Environment_Map) return Boolean
- is
- use Primitive_Options;
- Env : Environment_Map;
- Nested_Exists : Boolean;
- begin
- if Is_None (Iter.Current_Element) then
- return False;
- end if;
-
- Nested_Exists := Iter.Nested.Next (Env);
-
- if not Nested_Exists then
- Update_Current_Element (Iter);
- Iter.Nested.Reset;
- -- Stop the iteation if we can't build a complete environment
- -- after updating the current element and reseting the nested
- -- iterator.
- if Is_None (Iter.Current_Element) or else
- not Iter.Nested.Next (Env)
- then
- return False;
- end if;
- end if;
-
- Env.Include (Iter.Binding_Name, Extract (Iter.Current_Element));
- Result := Env;
- return True;
- end Update_Nested_Env;
-
- ----------------------------
- -- Update_Current_Element --
- ----------------------------
-
- procedure Update_Current_Element (Iter : in out Comprehension_Env_Iter) is
- use Primitive_Options;
- Element : Primitive;
- Element_Exists : constant Boolean := Iter.Gen.Next (Element);
- begin
- if Element_Exists then
- Iter.Current_Element := To_Option (Element);
- else
- Iter.Current_Element := None;
- end if;
- end Update_Current_Element;
-
- --------------------
- -- Create_New_Env --
- --------------------
-
- function Create_New_Env (Iter : in out Comprehension_Env_Iter;
- Result : out Environment_Map) return Boolean
- is
- use Primitive_Options;
- begin
- if Is_None (Iter.Current_Element) then
- return False;
- end if;
-
- Result.Include (Iter.Binding_Name, Extract (Iter.Current_Element));
- Update_Current_Element (Iter);
- return True;
- end Create_New_Env;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone
- (Iter : Comprehension_Env_Iter) return Comprehension_Env_Iter
- is
- use type Environment_Iters.Resetable_Access;
- Gen_Copy : constant Primitive_Iters.Iterator_Access :=
- new Primitive_Iters.Iterator_Interface'Class'(
- Primitive_Iters.Iterator_Interface'Class (Iter.Gen.Clone));
- Nested_Copy : constant Environment_Iters.Resetable_Access :=
- (if Iter.Nested = null then null
- else new Environment_Iters.Resetable_Iter'(Iter.Nested.Clone));
- begin
- return (Iter.Binding_Name, Iter.Current_Element, Gen_Copy, Nested_Copy);
- end Clone;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Iter : in out Comprehension_Env_Iter) is
- begin
- Primitive_Iters.Release_Access (Iter.Gen);
- Environment_Iters.Release_Access
- (Environment_Iters.Iterator_Access (Iter.Nested));
- end Release;
-
- --------------
- -- Evaluate --
- --------------
-
- overriding function Evaluate (Self : in out Closure;
- Element : Environment_Map) return Primitive
- is
- begin
- return Eval (Self.Ctx, Self.Body_Expr, Local_Bindings => Element);
- end Evaluate;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone (Self : Closure) return Closure is
- begin
- return Make_Closure (Self.Ctx, Self.Body_Expr);
- end Clone;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Self : in out Closure) is
- begin
- Self.Ctx.Release_Current_Frame;
- end Release;
-
- ------------------
- -- Make_Closure --
- ------------------
-
- function Make_Closure
- (Ctx : Eval_Context; Body_Expr : L.Expr) return Closure
- is
- begin
- return Closure'(Ctx.Ref_Frame, Body_Expr);
- end Make_Closure;
-
- --------------
- -- Evaluate --
- --------------
-
- function Evaluate (Self : in out Comprehension_Guard_Filter;
- Element : Environment_Map) return Boolean
- is
- Result : constant Primitive :=
- Eval (Self.Ctx, Self.Guard, Kind_Bool, Element);
- begin
- return Bool_Val (Result);
- end Evaluate;
-
- -----------
- -- Clone --
- -----------
-
- function Clone
- (Self : Comprehension_Guard_Filter) return Comprehension_Guard_Filter
- is
- begin
- return Self;
- end Clone;
-
- -----------------------
- -- Make_Guard_Filter --
- -----------------------
-
- function Make_Guard_Filter (Ctx : Eval_Context;
- Guard : L.Expr)
- return Comprehension_Guard_Filter
- is
- begin
- return Comprehension_Guard_Filter'(Ctx, Guard);
- end Make_Guard_Filter;
-
-end LKQL.Evaluation;
diff --git a/lkql/extensions/src/lkql-evaluation.ads b/lkql/extensions/src/lkql-evaluation.ads
deleted file mode 100644
index 50508a3f7..000000000
--- a/lkql/extensions/src/lkql-evaluation.ads
+++ /dev/null
@@ -1,142 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with GNATCOLL.Traces;
-
-with Iters.Maps;
-with Iters.Iterators;
-with LKQL.Primitives; use LKQL.Primitives;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-
-package LKQL.Evaluation is
-
- function Eval (Ctx : Eval_Context;
- Node : L.Lkql_Node'Class;
- Expected_Kind : Base_Primitive_Kind := No_Kind;
- Local_Bindings : Environment_Map :=
- String_Value_Maps.Empty_Map) return Primitive;
- -- Return the result of the AST node's evaluation in the given context.
- -- An Eval_Error will be raised if the node represents an invalid query or
- -- expression.
-
- function Eval_Default
- (Ctx : Eval_Context;
- Node : L.Lkql_Node'Class;
- Default : Primitive;
- Expected_Kind : Base_Primitive_Kind := No_Kind;
- Local_Bindings : Environment_Map :=
- String_Value_Maps.Empty_Map) return Primitive
- is
- (if Node.Is_Null then Default
- else Eval (Ctx, Node, Expected_Kind, Local_Bindings));
- -- If 'Node' is null return 'Default', otherwise call 'Eval' with the
- -- given arguments.
-
- procedure Check_Kind (Ctx : Eval_Context;
- Node : L.Lkql_Node;
- Expected_Kind : Valid_Primitive_Kind;
- Value : Primitive);
- -- Raise an exception and register an error in the evaluation context if
- -- `Value` doesn't have the expected kind.
-
- Eval_Trace : GNATCOLL.Traces.Trace_Handle
- := GNATCOLL.Traces.Create ("LKQL.EVAL");
-
-private
-
- -----------------------------------------
- -- Comprehensions environment iterator --
- -----------------------------------------
-
- package Environment_Iters is new Iters.Iterators (Environment_Map);
- -- Iterator that yields the environments generated by a list
- -- comprehension's generator expressions.
-
- type Comprehension_Env_Iter is new Environment_Iters.Iterator_Interface with
- record
- Binding_Name : Symbol_Type;
- -- Name associated with the generator
- Current_Element : Primitive_Options.Option;
- -- Value of the next element to be yielded
- Gen : Primitive_Iters.Iterator_Access;
- -- Iterator that yields the generator values
- Nested : Environment_Iters.Resetable_Access;
- -- 'Nested' generator that appeared at the right-hand side of the
- -- current generator in the generators list
- end record;
-
- overriding function Next (Iter : in out Comprehension_Env_Iter;
- Result : out Environment_Map) return Boolean;
-
- overriding function Clone
- (Iter : Comprehension_Env_Iter) return Comprehension_Env_Iter;
-
- overriding procedure Release (Iter : in out Comprehension_Env_Iter);
-
- type Comprehension_Env_Iter_Access is access all Comprehension_Env_Iter;
-
- ------------------------------
- -- Comprehension evaluation --
- ------------------------------
-
- package Env_Primitive_Maps is
- new Iters.Maps (Environment_Iters, Primitive_Iters);
- -- Mapping from environment values to primitive values
-
- type Closure is new Env_Primitive_Maps.Map_Funcs.Func with record
- Ctx : Eval_Context;
- -- Copy of the evaluation context at call site
- Body_Expr : L.Expr;
- -- Body of the closure
- end record;
-
- overriding function Evaluate (Self : in out Closure;
- Element : Environment_Map) return Primitive;
-
- overriding function Clone (Self : Closure) return Closure;
-
- overriding procedure Release (Self : in out Closure);
-
- function Make_Closure (Ctx : Eval_Context;
- Body_Expr : L.Expr)
- return Closure;
-
- type Comprehension_Guard_Filter is new Environment_Iters.Predicates.Func
- with record
- Ctx : Eval_Context;
- Guard : L.Expr;
- end record;
- -- Func that, given an environment, computes the value of a list
- -- comprehension's guard expression in the context of this environment.
-
- function Evaluate (Self : in out Comprehension_Guard_Filter;
- Element : Environment_Map) return Boolean;
-
- function Clone
- (Self : Comprehension_Guard_Filter) return Comprehension_Guard_Filter;
-
- function Make_Guard_Filter (Ctx : Eval_Context;
- Guard : L.Expr)
- return Comprehension_Guard_Filter;
-
-end LKQL.Evaluation;
diff --git a/lkql/extensions/src/lkql-functions.adb b/lkql/extensions/src/lkql-functions.adb
deleted file mode 100644
index e9e6768ae..000000000
--- a/lkql/extensions/src/lkql-functions.adb
+++ /dev/null
@@ -1,522 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Depth_Nodes; use LKQL.Depth_Nodes;
-with LKQL.Custom_Selectors; use LKQL.Custom_Selectors;
-with LKQL.Errors; use LKQL.Errors;
-with LKQL.Evaluation; use LKQL.Evaluation;
-with LKQL.Error_Handling; use LKQL.Error_Handling;
-with LKQL.Node_Extensions; use LKQL.Node_Extensions;
-with LKQL.Node_Data; use LKQL.Node_Data;
-
-with Ada.Strings.Wide_Wide_Unbounded;
-
-with Ada.Containers;
-
-package body LKQL.Functions is
- procedure Process_Function_Arguments
- (Ctx : Eval_Context;
- Call : L.Fun_Call;
- Param_Count : Natural;
- Skip_First_Arg : Boolean := False;
- Param_Index : access function (Param_Name : Symbol_Type)
- return Natural;
- Default_Value : access function (Param_Index : Positive)
- return Primitive_Option;
- Eval_Arg : access function (Param_Index : Positive;
- Arg_Expr : L.Expr)
- return Primitive;
- Match_Found : access procedure (Param_Index : Positive;
- Arg_Value : Primitive));
- -- Implements the common logic for processing a function call, such as
- -- checking existence of named arguments, arity, duplicate parameters, etc.
- -- If ``Skip_First_Arg`` is True, then we assume the call is a dot method
- -- call, and the ``Call`` syntax node doesn't contain the first argument.
-
- function Call_Builtin
- (Ctx : Eval_Context;
- Builtin_Descr : Builtin_Function_Description;
- Call : L.Fun_Call;
- First_Arg : Primitive := null) return Primitive;
- -- Call the given built-in function. If ``First_Arg`` has a non null value,
- -- then we assume it's a dot call to a built-in, and the ``Call`` syntax
- -- node will only contain the remaining arguments.
-
- function Eval_User_Fun_Call
- (Ctx : Eval_Context;
- Call : L.Fun_Call;
- Func : Primitive) return Primitive;
- -- Evaluate a call to a user-defined function
-
- function Eval_Builtin_Call
- (Ctx : Eval_Context;
- Call : L.Fun_Call;
- Fun : Primitive) return Primitive;
- -- Evaluate a call to a built-in function
-
- ---------------
- -- Eval_Call --
- ---------------
-
- function Eval_Call
- (Ctx : Eval_Context; Call : L.Fun_Call) return Primitive
- is
- Func : Primitive;
- use LCO;
- begin
- -- Special case for builtin-method calls. Since we don't want to create
- -- closures for built-in methods, we make a special case here where we
- -- recognize the case when the called entity can be a built-in method
- -- reference, and call them directly.
- if Call.F_Name.Kind = Lkql_Dot_Access then
- declare
- Node : constant L.Dot_Access := Call.F_Name.As_Dot_Access;
- Receiver : constant Primitive := Eval (Ctx, Node.F_Receiver);
- Builtin_Desc : constant Builtin_Method_Descriptor :=
- (Receiver.Kind,
- Symbol (Node.F_Member));
-
- Cur : Builtin_Methods_Maps.Cursor;
- begin
- -- No builtins on namespaces
- if Receiver.Kind /= Kind_Namespace then
- Cur := Get_Builtin_Methods (Ctx.Kernel).Find (Builtin_Desc);
- if Builtin_Methods_Maps.Has_Element (Cur) then
- return Call_Builtin
- (Ctx,
- Builtin_Methods_Maps.Element (Cur).all,
- Call,
- Receiver);
- end if;
- end if;
- end;
- end if;
-
- Func := Eval (Ctx, Call.F_Name);
-
- -- If this is a safe call and the callable is null, return unit.
- if Call.F_Has_Safe and then Is_Nullish (Func) then
- return Make_Unit_Primitive;
- end if;
-
- -- Called entity should be a function or a selector
- if Kind (Func) not in
- Kind_Function | Kind_Selector | Kind_Builtin_Function
- | Kind_Property_Reference
- then
- Raise_Invalid_Type (Ctx, Call.As_Lkql_Node,
- "function or selector", Func);
- end if;
-
- -- Call the proper eval sub function depending on the kind of the called
- -- entity.
- case Kind (Func) is
- when Kind_Function =>
- return Eval_User_Fun_Call (Ctx, Call, Func);
- when Kind_Selector =>
- return To_Primitive
- (Eval_User_Selector_Call (Ctx, Call, Func), Ctx.Pool);
- when Kind_Builtin_Function =>
- return Eval_Builtin_Call (Ctx, Call, Func);
- when Kind_Property_Reference =>
- return Eval_Node_Property
- (Ctx,
- Func.Property_Node,
- Func.Ref, Call.F_Arguments);
- when others =>
- raise Program_Error with "unreachable";
- end case;
- end Eval_Call;
-
- --------------------------------
- -- Process_Function_Arguments --
- --------------------------------
-
- procedure Process_Function_Arguments
- (Ctx : Eval_Context;
- Call : L.Fun_Call;
- Param_Count : Natural;
- Skip_First_Arg : Boolean := False;
- Param_Index : access function (Param_Name : Symbol_Type)
- return Natural;
- Default_Value : access function (Param_Index : Positive)
- return Primitive_Option;
- Eval_Arg : access function (Param_Index : Positive;
- Arg_Expr : L.Expr)
- return Primitive;
- Match_Found : access procedure (Param_Index : Positive;
- Arg_Value : Primitive))
- is
- type Has_Arg_Array is array (Positive range 1 .. Param_Count) of Boolean;
- -- Array of booleans, used to check whether an arg was passed.
-
- Has_Arg : Has_Arg_Array := (others => False);
- begin
-
- -- Do the argument evaluation and checking in the same pass
- for I in
- Call.F_Arguments.First_Child_Index .. Call.F_Arguments.Last_Child_Index
- loop
- declare
- Arg : constant L.Arg := Call.F_Arguments.Child (I).As_Arg;
- Arg_Name : constant Symbol_Type := Symbol (Arg.P_Name);
- begin
- if Arg_Name /= null then
-
- -- Named arg: check if the name exists in the definition's
- -- profile.
- declare
- Position : constant Natural := Param_Index (Arg_Name);
- begin
-
- if Position > 0 then
- -- Check that it has not already been seen
- if Has_Arg (Position) then
- Raise_Already_Seen_Arg (Ctx, Arg);
- end if;
-
- -- All is good, mark the arg as passed
- Has_Arg (Position) := True;
-
- Match_Found (Position, Eval_Arg (Position, Arg.P_Expr));
- else
- -- No parameter for this arg: raise
- Raise_Unknown_Argument (Ctx, Arg.P_Name);
- end if;
- end;
- else
- declare
- J : constant Positive :=
- (if Skip_First_Arg then I + 1 else I);
- begin
- -- Positional arg: check if there is an arg at this
- -- position.
- if J > Param_Count then
-
- -- No arg at this pos: raise
- Raise_Invalid_Arity (Ctx, Param_Count, Call.F_Arguments);
- else
-
- -- All is good, mark the arg as passed
- Has_Arg (J) := True;
-
- Match_Found (J, Eval_Arg (J, Arg.P_Expr));
- end if;
- end;
- end if;
- end;
- end loop;
-
- -- Second step: check that every arg has been passed, and evaluate
- -- default values for parameters that were passed no value.
- for I in Has_Arg_Array'Range loop
- -- We have no argument at position I
- if not (Has_Arg (I) or else (Skip_First_Arg and then I = 1)) then
- declare
- Default : constant Primitive_Option := Default_Value (I);
- begin
- -- It could be an arg with a default value ..
- if Primitive_Options.Is_Some (Default) then
-
- -- In that case eval the default value and add it to the
- -- args map.
- Match_Found (I, Primitive_Options.Extract (Default));
- else
- -- But if not, raise
- Raise_And_Record_Error
- (Ctx,
- Make_Eval_Error
- (Call,
- "Missing value for param #"
- & I'Wide_Wide_Image & " in call"));
- end if;
- end;
- end if;
- end loop;
- end Process_Function_Arguments;
-
- ------------------------
- -- Eval_User_Fun_Call --
- ------------------------
-
- function Eval_User_Fun_Call
- (Ctx : Eval_Context;
- Call : L.Fun_Call;
- Func : Primitive) return Primitive
- is
-
- use Callable_Caches;
-
- function Param_Index (Name : Symbol_Type) return Natural;
- function Default_Value (I : Positive) return Primitive_Option;
- function Eval_Arg (I : Positive; Arg : L.Expr) return Primitive;
- procedure Match_Found (Param_Index : Positive; Arg_Value : Primitive);
-
- Def : constant L.Base_Function := Func.Fun_Node;
- Env : constant LKQL.Primitives.Environment_Access :=
- Func.Frame;
-
- Def_Ext : constant Ext := Get_Ext (Def);
- Args_Bindings : Environment_Map;
- Has_Cache : constant Boolean := Func.Call_Cache /= No_Cache;
- Cache_Vector : Primitive_Vectors.Vector;
-
- -----------------
- -- Param_Index --
- -----------------
-
- function Param_Index (Name : Symbol_Type) return Natural is
- Cur : constant Params_Maps.Cursor :=
- Def_Ext.Content.Params.Find (Name);
- begin
- return (if Params_Maps.Has_Element (Cur)
- then Params_Maps.Element (Cur).Pos
- else 0);
- end Param_Index;
-
- -------------------
- -- Default_Value --
- -------------------
-
- function Default_Value (I : Positive) return Primitive_Option is
- Default_Expr : constant L.Expr :=
- Def.F_Parameters.Child (I).As_Parameter_Decl.F_Default_Expr;
- begin
- return (if Default_Expr.Is_Null
- then Primitive_Options.None
- else Primitive_Options.To_Option (Eval (Ctx, Default_Expr)));
- end Default_Value;
-
- --------------
- -- Eval_Arg --
- --------------
-
- function Eval_Arg (I : Positive; Arg : L.Expr) return Primitive is
- (Eval (Ctx, Arg));
-
- -----------------
- -- Match_Found --
- -----------------
-
- procedure Match_Found (Param_Index : Positive; Arg_Value : Primitive) is
- Param_Name : constant Symbol_Type := Symbol
- (Def.F_Parameters.Child
- (Param_Index).As_Parameter_Decl.P_Identifier);
-
- use Ada.Containers;
- begin
- Args_Bindings.Insert (Param_Name, Arg_Value);
- if Has_Cache then
- if Cache_Vector.Length < Count_Type (Param_Index) then
- Cache_Vector.Set_Length (Count_Type (Param_Index));
- end if;
- Cache_Vector (Param_Index) := Arg_Value;
- end if;
- end Match_Found;
-
- Eval_Ctx : constant Eval_Context :=
- Eval_Context'(Ctx.Kernel, Eval_Contexts.Environment_Access (Env));
- begin
- Process_Function_Arguments
- (Ctx,
- Call,
- Def.F_Parameters.Children_Count,
- False,
- Param_Index'Access,
- Default_Value'Access,
- Eval_Arg'Access,
- Match_Found'Access);
-
- if Has_Cache then
- declare
- Cached_Return : constant Primitive :=
- Query (Func.Call_Cache, Cache_Vector);
- begin
- if Cached_Return /= null then
- return Cached_Return;
- else
- declare
- Ret : constant Primitive := Eval
- (Eval_Ctx, Def.F_Body_Expr,
- Local_Bindings => Args_Bindings);
- begin
- Insert (Func.Call_Cache, Cache_Vector, Ret);
- return Ret;
- end;
- end if;
- end;
- end if;
-
- return Eval
- (Eval_Ctx, Def.F_Body_Expr, Local_Bindings => Args_Bindings);
- end Eval_User_Fun_Call;
-
- -----------------------------
- -- Eval_User_Selector_Call --
- -----------------------------
-
- function Eval_User_Selector_Call
- (Ctx : Eval_Context;
- Call : L.Fun_Call := L.No_Fun_Call;
- Sel : Primitive;
- Root_Node : Lk_Node := No_Lk_Node) return Selector_List
- is
- pragma Warnings (Off);
- Def : constant L.Selector_Decl := Sel.Sel_Node;
- Env : constant LKQL.Primitives.Environment_Access :=
- Sel.Frame;
- S_List : Selector_List;
- Eval_Ctx : constant Eval_Context :=
- Eval_Context'(Ctx.Kernel, Eval_Contexts.Environment_Access (Env));
-
- use L;
- begin
- if Root_Node = No_Lk_Node then
- if Call = L.No_Fun_Call
- or else Call.F_Arguments.Last_Child_Index = 0
- then
- Raise_And_Record_Error
- (Ctx,
- Make_Eval_Error
- (Call, "Selector call should have a node argument"));
- end if;
- end if;
-
- declare
- Root : Lk_Node :=
- (if Root_Node = No_Lk_Node
- then Eval
- (Ctx,
- Call.F_Arguments.Child (1).As_Expr_Arg.F_Value_Expr,
- Kind_Node).Node_Val
- else Root_Node);
-
- Selector_Iterator : Depth_Node_Iter_Access;
- Min_Depth_Expr, Max_Depth_Expr : L.Expr := L.No_Expr;
- begin
- -- If there is a call expression, try to get the min_depth and
- -- max_depth arguments to the selector call.
- if Call /= L.No_Fun_Call then
- Min_Depth_Expr := Call.P_Min_Depth_Expr;
- Max_Depth_Expr := Call.P_Max_Depth_Expr;
- end if;
-
- return Make_Selector_List
- (new Depth_Node_Iter'Class'
- (Depth_Node_Iter'Class
- (Make_Custom_Selector_Iter
- (Ctx, Sel, Min_Depth_Expr, Max_Depth_Expr, Root))));
- end;
-
- end Eval_User_Selector_Call;
-
- -----------------------
- -- Eval_Builtin_Call --
- -----------------------
-
- function Eval_Builtin_Call
- (Ctx : Eval_Context;
- Call : L.Fun_Call;
- Fun : Primitive) return Primitive
- is
- Builtin_Descr : constant Builtin_Function_Description :=
- Fun.Builtin_Fn.all;
- begin
- return Call_Builtin (Ctx, Builtin_Descr, Call);
- end Eval_Builtin_Call;
-
- ------------------
- -- Call_Builtin --
- ------------------
-
- function Call_Builtin
- (Ctx : Eval_Context;
- Builtin_Descr : Builtin_Function_Description;
- Call : L.Fun_Call;
- First_Arg : Primitive := null) return Primitive
- is
- function Param_Index (Name : Symbol_Type) return Natural;
- function Default_Value (I : Positive) return Primitive_Option;
- function Eval_Arg (I : Positive; Arg : L.Expr) return Primitive;
- procedure Match_Found (Param_Index : Positive; Arg_Value : Primitive);
-
- Param_Values : Primitive_Array (Builtin_Descr.Params'Range);
-
- -----------------
- -- Param_Index --
- -----------------
-
- function Param_Index (Name : Symbol_Type) return Natural is
- use type Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
- begin
- for I in 1 .. Builtin_Descr.N loop
- if Builtin_Descr.Params (I).Name = Name.all then
- return I;
- end if;
- end loop;
- return 0;
- end Param_Index;
-
- -------------------
- -- Default_Value --
- -------------------
-
- function Default_Value (I : Positive) return Primitive_Option is
- (Builtin_Descr.Params (I).Default_Value);
-
- --------------
- -- Eval_Arg --
- --------------
-
- function Eval_Arg (I : Positive; Arg : L.Expr) return Primitive is
- (Eval (Ctx, Arg, Builtin_Descr.Params (I).Expected_Kind));
-
- -----------------
- -- Match_Found --
- -----------------
-
- procedure Match_Found (Param_Index : Positive; Arg_Value : Primitive) is
- begin
- Param_Values (Param_Index) := Arg_Value;
- end Match_Found;
-
- begin
- Process_Function_Arguments
- (Ctx,
- Call,
- Builtin_Descr.N,
- -- ??? GNAT bug: /= doesn't work here.
- not (First_Arg = null),
- Param_Index'Access,
- Default_Value'Access,
- Eval_Arg'Access,
- Match_Found'Access);
-
- if not (First_Arg = null) then
- Param_Values (1) := First_Arg;
- end if;
-
- return Builtin_Descr.Fn_Access (Ctx, Param_Values);
- end Call_Builtin;
-
-end LKQL.Functions;
diff --git a/lkql/extensions/src/lkql-functions.ads b/lkql/extensions/src/lkql-functions.ads
deleted file mode 100644
index 89206381e..000000000
--- a/lkql/extensions/src/lkql-functions.ads
+++ /dev/null
@@ -1,42 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with LKQL.Primitives; use LKQL.Primitives;
-with LKQL.Selector_Lists; use LKQL.Selector_Lists;
-
-private package LKQL.Functions is
-
- function Eval_Call
- (Ctx : Eval_Context; Call : L.Fun_Call) return Primitive;
- -- Evaluate a call, which can be to either a user defined function or
- -- selector, or to a built-in function.
-
- function Eval_User_Selector_Call
- (Ctx : Eval_Context;
- Call : L.Fun_Call := L.No_Fun_Call;
- Sel : Primitive;
- Root_Node : Lk_Node := No_Lk_Node) return Selector_List;
- -- Eval a call to a selector
-
-end LKQL.Functions;
diff --git a/lkql/extensions/src/lkql-lk_nodes_iterators.adb b/lkql/extensions/src/lkql-lk_nodes_iterators.adb
deleted file mode 100644
index 03ca5638e..000000000
--- a/lkql/extensions/src/lkql-lk_nodes_iterators.adb
+++ /dev/null
@@ -1,188 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Libadalang.Generic_API; use Libadalang.Generic_API;
-with Libadalang.Generic_API.Introspection;
-use Libadalang.Generic_API.Introspection;
-
-package body LKQL.Lk_Nodes_Iterators is
-
- procedure Add_Children
- (Iter : in out Child_Iterator;
- Node : LK.Lk_Node);
-
- procedure Initialize_Next_Elements (Iter : in out Child_Iterator);
-
- -------------------------
- -- Make_Child_Iterator --
- -------------------------
-
- function Make_Child_Iterator
- (Nodes : Lk_Node_Array) return Child_Iterator
- is
- Result : Child_Iterator;
- begin
- for Node of Nodes loop
- Result.Roots.Append (Node);
- end loop;
-
- Initialize_Next_Elements (Result);
- return Result;
- end Make_Child_Iterator;
-
- -------------------------
- -- Make_Child_Iterator --
- -------------------------
-
- function Make_Child_Iterator
- (Nodes : Lk_Node_Vector;
- Follow_Instantiations : Boolean := False) return Child_Iterator
- is
- Result : Child_Iterator;
- begin
- Result.Roots := Nodes;
- Result.Follow_Instantiations := Follow_Instantiations;
- Initialize_Next_Elements (Result);
- return Result;
- end Make_Child_Iterator;
-
- ----------
- -- Next --
- ----------
-
- overriding function Next
- (Iter : in out Child_Iterator;
- Result : out Lk_Node) return Boolean is
- begin
- if Iter.Next_Elements.Is_Empty then
- return False;
- end if;
-
- -- This implements a DFS traversal, so that given the tree:
- --
- -- a __ b _ d
- -- \ \__ e
- -- \__ c
- --
- -- This will return the list [a, b, d, e, c]
- --
- -- This works by adding children on the "stack" in reverse order, and
- -- picking the last one everytime:
- --
- -- [a] elem=a (Initial state)
- -- [c, b] elem=b
- -- [c, e, d] elem=d
- -- [c, e] elem=e
- -- [c] elem=c
-
- Result := Iter.Next_Elements.Last_Element;
- Iter.Next_Elements.Delete_Last;
- Add_Children (Iter, Result);
-
- return True;
- end Next;
-
- ------------------
- -- Add_Children --
- ------------------
-
- procedure Add_Children (Iter : in out Child_Iterator; Node : Lk_Node) is
- function In_Generic_Instantiation (Node : Lk_Node) return Boolean is
- (LKI.As_Array
- (LKI.Eval_Node_Member
- (Node,
- Member_Refs.Ada_Node_P_Generic_Instantiations))'Length /= 0);
- -- Return True if Node is part of a generic instantiation
-
- begin
- for I in reverse 1 .. Node.Children_Count loop
- if not Node.Child (I).Is_Null then
- Iter.Next_Elements.Append (Node.Child (I));
- end if;
- end loop;
-
- if Iter.Follow_Instantiations then
- if LKI.Type_Matches (Node, Type_Refs.Generic_Instantiation) then
- declare
- Gen_Decl : constant LK.Lk_Node := LKI.As_Node
- (LKI.Eval_Node_Member
- (Node,
- Member_Refs.
- Generic_Instantiation_P_Designated_Generic_Decl));
- Gen_Body : constant LK.Lk_Node := LKI.As_Node
- (LKI.Eval_Node_Member
- (Gen_Decl,
- Member_Refs.Basic_Decl_P_Body_Part_For_Decl,
- (1 => LKI.From_Bool (Ada_Lang_Id, False))));
-
- begin
- Iter.Next_Elements.Append (Gen_Decl);
-
- if not Gen_Body.Is_Null then
- Iter.Next_Elements.Append (Gen_Body);
- end if;
- end;
-
- -- Also traverse stub bodies if already part of an instantiation
-
- elsif LKI.Type_Matches (Node, Type_Refs.Body_Stub)
- and then In_Generic_Instantiation (Node)
- then
- declare
- Separate_Body : constant LK.Lk_Node := LKI.As_Node
- (LKI.Eval_Node_Member
- (Node,
- Member_Refs.Basic_Decl_P_Next_Part_For_Decl,
- (1 => LKI.From_Bool (Ada_Lang_Id, False))));
- begin
- Iter.Next_Elements.Append (Separate_Body);
- end;
- end if;
- end if;
- end Add_Children;
-
- ------------------------------
- -- Initialize_Next_Elements --
- ------------------------------
-
- procedure Initialize_Next_Elements (Iter : in out Child_Iterator) is
- begin
- for El of Iter.Roots loop
- if not El.Is_Null then
- Iter.Next_Elements.Append (El);
- end if;
- end loop;
- end Initialize_Next_Elements;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone (Iter : Child_Iterator) return Child_Iterator is
- Res : Child_Iterator := (Roots => Iter.Roots, others => <>);
- begin
- Initialize_Next_Elements (Res);
- return Res;
- end Clone;
-
-end LKQL.Lk_Nodes_Iterators;
diff --git a/lkql/extensions/src/lkql-lk_nodes_iterators.ads b/lkql/extensions/src/lkql-lk_nodes_iterators.ads
deleted file mode 100644
index c55d4b272..000000000
--- a/lkql/extensions/src/lkql-lk_nodes_iterators.ads
+++ /dev/null
@@ -1,84 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Iters.Iterators;
-with Ada.Containers.Doubly_Linked_Lists;
-
-package LKQL.Lk_Nodes_Iterators is
-
- ------------------------
- -- AST Node Iterators --
- ------------------------
-
- package Lk_Node_Iterators is new Iters.Iterators (Lk_Node);
- -- Iterators of refcounted AST node pointers
-
- subtype Lk_Node_Iterator is Lk_Node_Iterators.Iterator_Interface;
- -- Iterator of refcounted AST node pointers
-
- subtype Lk_Node_Iterator_Access is Lk_Node_Iterators.Iterator_Access;
- -- Pointer to an iterator of refcounted AST node pointers
-
- subtype Lk_Node_Iterator_Predicate is Lk_Node_Iterators.Predicates.Func;
- -- Predicate on refcounted AST node pointers
-
- subtype Lk_Node_Predicate_Access is
- Lk_Node_Iterators.Predicates.Func_Access;
- -- Pointer to a predicate on AST node pointers
-
- --------------------
- -- Child_Iterator --
- --------------------
-
- type Child_Iterator is new Lk_Node_Iterator with private;
- -- Iterator that yields the children of a node in a depth-first fashion
-
- overriding function Next
- (Iter : in out Child_Iterator;
- Result : out Lk_Node) return Boolean;
-
- overriding function Clone (Iter : Child_Iterator) return Child_Iterator;
-
- function Make_Child_Iterator (Nodes : Lk_Node_Array) return Child_Iterator;
- function Make_Child_Iterator
- (Nodes : Lk_Node_Vector;
- Follow_Instantiations : Boolean := False) return Child_Iterator;
-
-private
-
- package AST_Node_Lists is
- new Ada.Containers.Doubly_Linked_Lists
- (Element_Type => Lk_Node,
- "=" => "=");
- -- Doubly-linked lists of refcounted AST node pointers
-
- subtype AST_Node_List is AST_Node_Lists.List;
- -- Doubly-linked list of refcounted AST node pointers
-
- type Child_Iterator is new Lk_Node_Iterator with record
- Roots : Lk_Node_Vector;
- Next_Elements : AST_Node_List;
- Follow_Instantiations : Boolean := False;
- end record;
-
-end LKQL.Lk_Nodes_Iterators;
diff --git a/lkql/extensions/src/lkql-node_data.adb b/lkql/extensions/src/lkql-node_data.adb
deleted file mode 100644
index bed280d89..000000000
--- a/lkql/extensions/src/lkql-node_data.adb
+++ /dev/null
@@ -1,419 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Adaptive_Integers; use LKQL.Adaptive_Integers;
-with LKQL.Errors; use LKQL.Errors;
-with LKQL.Evaluation; use LKQL.Evaluation;
-with LKQL.Error_Handling; use LKQL.Error_Handling;
-
-with Ada.Exceptions; use Ada.Exceptions;
-with Langkit_Support.Errors;
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-with GNATCOLL.GMP.Integers;
-
-package body LKQL.Node_Data is
-
- function Make_Primitive
- (Ctx : Eval_Context;
- Value : LKI.Value_Ref) return Primitive;
-
- function Make_Value_Type
- (Value : Primitive;
- Target_Type : LKI.Type_Ref;
- Ctx : Eval_Context) return LKI.Value_Ref;
-
- function List_To_Value_Ref
- (Value : Primitive_List;
- Array_Type : LKI.Type_Ref;
- Ctx : Eval_Context) return LKI.Value_Ref;
-
- ---------------------------
- -- Get_Struct_Member_Ref --
- ---------------------------
-
- function Get_Struct_Member_Ref
- (Ctx : Eval_Context;
- Receiver : LK.Lk_Node;
- Field_Name : L.Identifier) return LKI.Struct_Member_Ref
- is
- T : constant LKI.Type_Ref := LKI.Type_Of (Receiver);
- begin
- return Ctx.Get_Name_Map.Lookup_Struct_Member
- (T, Symbol (Field_Name));
- end Get_Struct_Member_Ref;
-
- -----------------------
- -- Access_Node_Field --
- -----------------------
-
- function Access_Node_Field (Ctx : Eval_Context;
- Receiver : LK.Lk_Node;
- Field_Name : L.Identifier) return Primitive
- is
- Ref : constant LKI.Struct_Member_Ref :=
- Get_Struct_Member_Ref (Ctx, Receiver, Field_Name);
-
- use LKI;
- begin
- if Ref = LKI.No_Struct_Member_Ref then
- Raise_And_Record_Error
- (Ctx, Make_Eval_Error (Field_Name, "No such field"));
- elsif LKI.Is_Property (Ref) then
-
- -- TODO: This is a special case for some properties, but that's ugly
- -- as hell.
- if LKI.Member_Last_Argument (Ref) = No_Argument_Index then
- declare
- S : constant Symbol_Type := Symbol (Field_Name);
- begin
- if S.all in "children" | "unit" | "parent" then
- return Make_Primitive
- (Ctx, LKI.Eval_Node_Member (Receiver, Ref));
- end if;
- end;
- end if;
-
- return Make_Property_Reference (Receiver, Ref, Ctx.Pool);
- end if;
-
- return Make_Primitive (Ctx, LKI.Eval_Node_Member (Receiver, Ref));
- exception
- when Error : LKE.Precondition_Failure =>
- Raise_And_Record_Error
- (Ctx, Make_Eval_Error (Field_Name,
- To_Text (Exception_Message (Error))));
- end Access_Node_Field;
-
- ------------------------
- -- Eval_Node_Property --
- ------------------------
-
- function Eval_Node_Property (Ctx : Eval_Context;
- Receiver : LK.Lk_Node;
- Property_Name : L.Identifier;
- Args : L.Arg_List) return Primitive
- is
-
- Ref : constant LKI.Struct_Member_Ref :=
- Get_Struct_Member_Ref (Ctx, Receiver, Property_Name);
-
- use LKI;
- begin
- if Ref = LKI.No_Struct_Member_Ref then
- Raise_And_Record_Error
- (Ctx, Make_Eval_Error (Property_Name, "No such field"));
- end if;
-
- return Eval_Node_Property (Ctx, Receiver, Ref, Args);
- exception
- when Error : LKE.Precondition_Failure =>
- Raise_And_Record_Error
- (Ctx, Make_Eval_Error (Property_Name,
- To_Text (Exception_Message (Error))));
-
- end Eval_Node_Property;
-
- ------------------------
- -- Eval_Node_Property --
- ------------------------
-
- function Eval_Node_Property
- (Ctx : Eval_Context;
- Receiver : LK.Lk_Node;
- Property_Ref : LKI.Struct_Member_Ref;
- Args : L.Arg_List) return Primitive
- is
-
- Arity : constant Natural
- := Natural (LKI.Member_Last_Argument (Property_Ref));
-
- function Value_Ref_Array_From_Args
- (Ctx : Eval_Context;
- Ref : LKI.Struct_Member_Ref;
- Args : L.Arg_List)
- return LKI.Value_Ref_Array;
- -- Evaluate the given arguments and convert them to Value_Type values.
-
- -------------------------------
- -- Value_Ref_Array_From_Args --
- -------------------------------
-
- function Value_Ref_Array_From_Args
- (Ctx : Eval_Context;
- Ref : LKI.Struct_Member_Ref;
- Args : L.Arg_List) return LKI.Value_Ref_Array
- is
- Result : LKI.Value_Ref_Array (1 .. Arity);
- use LKI;
- begin
- for I in 1 .. Arity loop
- declare
- Val : constant LKI.Value_Ref :=
- (if I <= Args.Children_Count
- then Make_Value_Type
- (Eval (Ctx, Args.List_Child (I).P_Expr),
- Member_Argument_Type (Ref, Argument_Index (I)),
- Ctx)
- else Member_Argument_Default_Value
- (Ref, Argument_Index (I)));
- begin
- if Val = No_Value_Ref then
- Raise_Invalid_Arity (Ctx, Arity, Args);
- else
- Result (I) := Val;
- end if;
- end;
- end loop;
-
- return Result;
- end Value_Ref_Array_From_Args;
-
- Result : Primitive;
- Property_Args : constant LKI.Value_Ref_Array :=
- Value_Ref_Array_From_Args
- (Ctx, Property_Ref, Args);
-
- begin
- if Args.Children_Count > Arity then
- Raise_Invalid_Arity
- (Ctx, Natural (LKI.Member_Last_Argument (Property_Ref)), Args);
- end if;
-
- Result := Make_Primitive
- (Ctx, LKI.Eval_Node_Member (Receiver, Property_Ref, Property_Args));
-
- return Result;
- exception
- when Error : LKE.Precondition_Failure =>
- Raise_And_Record_Error
- (Ctx, Make_Eval_Error (Args.Parent,
- To_Text (Exception_Message (Error))));
- when Error : Langkit_Support.Errors.Property_Error =>
-
- -- Wrap property errors in regular LKQL eval errors.
- Raise_And_Record_Error
- (Ctx,
- Make_Eval_Error
- (Args.Parent,
- To_Text ("PROPERTY_ERROR:" & Exception_Message (Error)),
- -- We embed the property error information in the eval error
- -- data.
- Property_Error_Info => Save_Occurrence (Error)));
- end Eval_Node_Property;
-
- --------------------
- -- Make_Primitive --
- --------------------
-
- function Make_Primitive
- (Ctx : Eval_Context; Value : LKI.Value_Ref) return Primitive
- is
- T : constant LKI.Type_Ref := LKI.Type_Of (Value);
- use LKI;
- begin
- case LKI.Category (T) is
- when Analysis_Unit_Category =>
- return To_Primitive (LKI.As_Unit (Value), Ctx.Pool);
- when Big_Int_Category =>
- return To_Primitive
- (Adaptive_Integers.Create
- (GNATCOLL.GMP.Integers.Image (LKI.As_Big_Int (Value))),
- Ctx.Pool);
- when Bool_Category =>
- return To_Primitive (LKI.As_Bool (Value));
- when Int_Category =>
- return To_Primitive (LKI.As_Int (Value), Ctx.Pool);
- when String_Category =>
- return To_Primitive (LKI.As_String (Value), Ctx.Pool);
- when Char_Category =>
- return To_Primitive (LKI.As_Char (Value) & "", Ctx.Pool);
- when Token_Category =>
- return To_Primitive (LKI.As_Token (Value), Ctx.Pool);
- when Symbol_Category =>
- return To_Primitive (LKI.As_Symbol (Value), Ctx.Pool);
- when Enum_Category =>
- return To_Primitive
- (LKN.Format_Name
- (LKI.Enum_Value_Name (LKI.As_Enum (Value)), LKN.Lower),
- Ctx.Pool);
- when Array_Category =>
- declare
- Res : constant Primitive := Make_Empty_List (Ctx.Pool);
- Arr : constant Value_Ref_Array := LKI.As_Array (Value);
- begin
- for J in Arr'Range loop
- declare
- V : constant LKI.Value_Ref := Arr (J);
- Prim : constant Primitive :=
- Make_Primitive (Ctx, V);
- begin
- Res.List_Val.Elements.Append (Prim);
- end;
- end loop;
-
- return Res;
- end;
- when Struct_Category =>
- if LKI.Is_Node_Type (T) then
- return To_Primitive (LKI.As_Node (Value), Ctx.Pool);
- else
- -- Structs are mapped to LKQL objects
- declare
- Membs : constant Struct_Member_Ref_Array := Members (T);
- Ret : constant Primitive := Make_Empty_Object (Ctx.Pool);
- begin
- for Member of Membs loop
- Ret.Obj_Assocs.Elements.Include
- (Find (Get_Context (Ctx.Kernel.all).Get_Symbol_Table,
- LKN.Format_Name
- (LKI.Member_Name (Member), LKN.Lower)),
- Make_Primitive (Ctx, LKI.Eval_Member (Value, Member)));
- end loop;
- return Ret;
- end;
- end if;
-
- when others =>
- Ctx.Raise_Error
- (L.No_Lkql_Node,
- "Unsupported value type from the introspection API: " &
- LKI.Category (T)'Wide_Wide_Image);
- end case;
-
- end Make_Primitive;
-
- ---------------------
- -- Make_Value_Type --
- ---------------------
-
- function Make_Value_Type
- (Value : Primitive;
- Target_Type : LKI.Type_Ref;
- Ctx : Eval_Context) return LKI.Value_Ref
- is
- use LKI;
-
- Target_Cat : constant LKI.Type_Category := Category (Target_Type);
-
- Id : constant Langkit_Support.Generic_API.Language_Id :=
- Language (Target_Type);
- begin
- case Value.Kind is
- when Kind_List =>
- if Target_Cat = LKI.Array_Category then
- return List_To_Value_Ref
- (Value.List_Val.all, Target_Type, Ctx);
- end if;
-
- when Kind_Str =>
- if Target_Cat = LKI.Enum_Category then
-
- -- TODO: This actually can't be tested with LAL because we have
- -- no properties that take enums as parameters, and we don't
- -- want to add one just for the sake of testing that. Let's see
- -- if we add such a property someday, or when we have the
- -- possibility of testing with various Langkit based languages.
-
- return LKI.Create_Enum
- (Ctx.Get_Name_Map.Lookup_Enum_Value
- (Target_Type,
- Ctx.Symbol (Value.Str_Val.all)));
-
- elsif Target_Cat = LKI.Symbol_Category then
- return LKI.From_Symbol
- (Id, Value.Str_Val.all);
-
- elsif Target_Cat = LKI.Char_Category then
- if Value.Str_Val'Length > 1 then
- Ctx.Raise_Error
- (L.No_Lkql_Node, "String too long for conversion to char");
- end if;
-
- return LKI.From_Char
- (Id, Value.Str_Val (Value.Str_Val'First));
- else
- return LKI.From_String
- (Id, Value.Str_Val.all);
- end if;
-
- when Kind_Int =>
- if Target_Cat = LKI.Int_Category then
- return LKI.From_Int (Id, +Value.Int_Val);
- elsif Target_Cat = LKI.Big_Int_Category then
- return LKI.From_Big_Int
- (Id, GNATCOLL.GMP.Integers.Make (Image (Value.Int_Val)));
- end if;
-
- when Kind_Bool =>
- if Target_Cat = LKI.Bool_Category then
- return LKI.From_Bool (Id, Value.Bool_Val);
- end if;
-
- when Kind_Node =>
- if LKI.Is_Node_Type (Target_Type) then
- return LKI.From_Node (Id, Value.Node_Val);
- else
- Ctx.Raise_Error (L.No_Lkql_Node, "Cannot pass struct in");
- end if;
-
- when Kind_Analysis_Unit =>
- if Target_Cat = LKI.Analysis_Unit_Category then
- return LKI.From_Unit (Id, Value.Analysis_Unit_Val);
- end if;
-
- when others => null;
- end case;
-
- Ctx.Raise_Error
- (L.No_Lkql_Node,
- To_Text
- ("Cannot convert a " & To_String (Value.Kind)
- & " to a " & Debug_Name (Target_Type)));
- end Make_Value_Type;
-
- -----------------------
- -- List_To_Value_Ref --
- -----------------------
-
- function List_To_Value_Ref
- (Value : Primitive_List;
- Array_Type : LKI.Type_Ref;
- Ctx : Eval_Context) return LKI.Value_Ref
- is
- Values : LKI.Value_Ref_Array
- (Value.Elements.First_Index .. Value.Elements.Last_Index);
-
- Element_Type : constant LKI.Type_Ref :=
- LKI.Array_Element_Type (Array_Type);
-
- begin
- for I in Value.Elements.First_Index .. Value.Elements.Last_Index loop
- Values (I) := Make_Value_Type (Value.Elements (I), Element_Type, Ctx);
- end loop;
-
- return LKI.Create_Array (Array_Type, Values);
- end List_To_Value_Ref;
-
-end LKQL.Node_Data;
diff --git a/lkql/extensions/src/lkql-node_data.ads b/lkql/extensions/src/lkql-node_data.ads
deleted file mode 100644
index e6c438669..000000000
--- a/lkql/extensions/src/lkql-node_data.ads
+++ /dev/null
@@ -1,59 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Primitives; use LKQL.Primitives;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-
-package LKQL.Node_Data is
-
- function Get_Struct_Member_Ref
- (Ctx : Eval_Context;
- Receiver : LK.Lk_Node;
- Field_Name : L.Identifier) return LKI.Struct_Member_Ref;
- -- Get the member reference for given receiver and field name. This
- -- function exists so that the evaluator can eventually cache the member
- -- reference rt. recompute it everytime.
-
- function Access_Node_Field
- (Ctx : Eval_Context;
- Receiver : LK.Lk_Node;
- Field_Name : L.Identifier) return Primitive;
- -- Return the value of the field designated by 'Field_Name' on 'Receiver'.
- -- An exception will be raised if there is no such field.
-
- function Eval_Node_Property
- (Ctx : Eval_Context;
- Receiver : LK.Lk_Node;
- Property_Name : L.Identifier;
- Args : L.Arg_List) return Primitive
- with Pre => not Args.Is_Null;
- function Eval_Node_Property
- (Ctx : Eval_Context;
- Receiver : LK.Lk_Node;
- Property_Ref : LKI.Struct_Member_Ref;
- Args : L.Arg_List) return Primitive;
- -- Evaluate the property designated by 'Property_Name' on 'Receiver'.
- -- An exception will be raised if there is no such property or if the call
- -- arity doesn't match the arity of the property.
-
-end LKQL.Node_Data;
diff --git a/lkql/extensions/src/lkql-node_extensions.adb b/lkql/extensions/src/lkql-node_extensions.adb
deleted file mode 100644
index e8389951a..000000000
--- a/lkql/extensions/src/lkql-node_extensions.adb
+++ /dev/null
@@ -1,48 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Deallocation;
-
-package body LKQL.Node_Extensions is
- -------------
- -- Destroy --
- -------------
-
- procedure Destroy (Self : in out Ext) is
- procedure Free_Pattern is new Ada.Unchecked_Deallocation
- (GNAT.Regpat.Pattern_Matcher, Regex_Matcher_Access);
-
- procedure Free is new Ada.Unchecked_Deallocation
- (Lkql_Node_Extension, Ext);
- begin
- case Self.Content.Kind is
- when LCO.Lkql_Regex_Pattern =>
- Free_Pattern (Self.Content.Compiled_Pattern);
- when LCO.Lkql_Base_String_Literal =>
- Free (Self.Content.Denoted_Value);
- when others =>
- null;
- end case;
- Free (Self);
- end Destroy;
-end LKQL.Node_Extensions;
diff --git a/lkql/extensions/src/lkql-node_extensions.ads b/lkql/extensions/src/lkql-node_extensions.ads
deleted file mode 100644
index fbd407679..000000000
--- a/lkql/extensions/src/lkql-node_extensions.ads
+++ /dev/null
@@ -1,111 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Hashed_Maps;
-with GNAT.Regpat;
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-
--- This package is the user facing parts of the LKQL node extension mechanism.
--- It allows us to extend nodes with pre-computed information stored in
--- ``Node_Ext`` records that are allocated and attached to LKQL nodes.
-
-package LKQL.Node_Extensions is
-
- ------------------
- -- Custom data --
- ------------------
-
- -- This section contains all the custom data types used to store
- -- information on nodes in different cases.
-
- type Formal_Param_Info is record
- Param : L.Parameter_Decl;
- -- Referenced parameter decl
-
- Pos : Positive;
- -- Position of the parameter in the function profile
- end record;
- -- Store information about a formal parameter
-
- package Params_Maps is new Ada.Containers.Hashed_Maps
- (Key_Type => Symbol_Type,
- Element_Type => Formal_Param_Info,
- Hash => Hash,
- Equivalent_Keys => "=");
- -- Mapping of name to formal parameter information. Used to speed up lookup
- -- of parameters in function calls.
-
- type Regex_Matcher_Access is access GNAT.Regpat.Pattern_Matcher;
- -- Store a compiled regular expression pattern. Used by LKQL's pattern
- -- matching routine to avoid having to recompile patterns for each query.
-
- ------------------------
- -- Node extension API --
- ------------------------
-
- -- This section contains the main types and subprograms used to interact
- -- with node extensions. At a high level, the most important entry point is
- -- the ``Get_Ext`` function.
-
- type Node_Ext (Kind : LCO.Lkql_Node_Kind_Type := LCO.Lkql_Expr_Arg)
- is record
- case Kind is
- when LCO.Lkql_Base_Function =>
- Params : Params_Maps.Map;
- -- Param_Map for the function, used to speedup lookup of
- -- parameters in calls.
- when LCO.Lkql_Regex_Pattern =>
- Compiled_Pattern : Regex_Matcher_Access;
-
- when LCO.Lkql_Node_Kind_Pattern =>
- Expected_Type : LKI.Type_Ref;
-
- when LCO.Lkql_Base_String_Literal =>
- Denoted_Value : Text_Access;
-
- when others => null;
- end case;
- end record;
- -- Discriminated record containing data depending on the type of the LKQL
- -- node. This type is wrapped because we cannot have a default value
- -- discriminated record inheriting from L.Extension_Base.
-
- type Lkql_Node_Extension is new L.Extension_Base with record
- Content : Node_Ext;
- end record;
- -- Wrapper containing the ``Node_Ext`` instance that actually contains the
- -- info.
-
- type Ext is access all Lkql_Node_Extension;
- -- Access to an extension record.
-
- procedure Destroy (Self : in out Ext);
- -- Destroy an extension through its pointer.
-
- function Get_Ext
- is new L.Get_Extension
- (Lkql_Node_Extension, Ext);
- -- Main entry point. Returns the extension for a given node.
-
-end LKQL.Node_Extensions;
diff --git a/lkql/extensions/src/lkql-patterns-match.adb b/lkql/extensions/src/lkql-patterns-match.adb
deleted file mode 100644
index 4ca84585d..000000000
--- a/lkql/extensions/src/lkql-patterns-match.adb
+++ /dev/null
@@ -1,241 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Patterns.Nodes; use LKQL.Patterns.Nodes;
-with LKQL.Evaluation; use LKQL.Evaluation;
-with LKQL.Error_Handling;
-with LKQL.Node_Extensions;
-
-with Ada.Assertions; use Ada.Assertions;
-
-with GNAT.Regpat;
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-package body LKQL.Patterns.Match is
-
- -------------------------
- -- Match_Pattern_Array --
- -------------------------
-
- function Match_Pattern_Array (Ctx : Eval_Context;
- Patterns : L.Base_Pattern_Array;
- Value : Primitive)
- return Match_Array_Result
- is
- Current_Result : Match_Result;
- begin
- for I in Patterns'Range loop
- Current_Result := Match_Pattern (Ctx, Patterns (I), Value);
-
- if Current_Result.Is_Success then
- return Match_Array_Result'
- (Current_Result.Matched_Value, I);
- end if;
- end loop;
-
- return Match_Array_Result'(others => <>);
- end Match_Pattern_Array;
-
- -------------------
- -- Match_Pattern --
- -------------------
-
- function Match_Pattern (Ctx : Eval_Context;
- Pattern : L.Base_Pattern;
- Value : Primitive) return Match_Result
- is
- begin
- return (if Pattern.Kind in LCO.Lkql_Unfiltered_Pattern
- then Match_Unfiltered (Ctx, Pattern.As_Unfiltered_Pattern, Value)
- else Match_Filtered (Ctx, Pattern.As_Filtered_Pattern, Value));
- end Match_Pattern;
-
- --------------------
- -- Match_Filtered --
- --------------------
-
- function Match_Filtered (Ctx : Eval_Context;
- Pattern : L.Filtered_Pattern;
- Value : Primitive) return Match_Result
- is
- Result : constant Match_Result :=
- Match_Unfiltered (Ctx, Pattern.F_Pattern, Value);
- Predicate_Result : Primitive;
- begin
- if not Result.Is_Success then
- return Match_Failure;
- end if;
-
- Predicate_Result := Eval (Ctx, Pattern.F_Predicate, Kind_Bool);
-
- if not Bool_Val (Predicate_Result) then
- return Match_Failure;
- end if;
-
- return Result;
- end Match_Filtered;
-
- ----------------------
- -- Match_Unfiltered --
- ----------------------
-
- function Match_Unfiltered (Ctx : Eval_Context;
- Pattern : L.Unfiltered_Pattern;
- Value : Primitive) return Match_Result
- is
- (case Pattern.Kind is
- when LCO.Lkql_Value_Pattern =>
- Match_Value (Ctx, Pattern.As_Value_Pattern, Value),
- when LCO.Lkql_Binding_Pattern =>
- Match_Binding (Ctx, Pattern.As_Binding_Pattern, Value),
- when others =>
- raise Assertion_Error with
- "Not an unfiltered pattern kind: " & L.Kind_Name (Pattern));
-
- -----------------
- -- Match_Value --
- -----------------
-
- function Match_Value (Ctx : Eval_Context;
- Pattern : L.Value_Pattern;
- Value : Primitive) return Match_Result
- is
- use LKQL.Error_Handling;
- begin
- case Pattern.Kind is
- when LCO.Lkql_Paren_Pattern =>
- return Match_Pattern
- (Ctx, Pattern.As_Paren_Pattern.F_Pattern, Value);
-
- when LCO.Lkql_Or_Pattern =>
- declare
- Or_Pat : constant L.Or_Pattern := Pattern.As_Or_Pattern;
- Left_Res : constant Match_Result :=
- Match_Pattern (Ctx, Or_Pat.F_Left, Value);
- begin
- if Left_Res.Is_Success then
- return Left_Res;
- else
- return Match_Pattern (Ctx, Or_Pat.F_Right, Value);
- end if;
- end;
-
- when LCO.Lkql_Not_Pattern =>
- declare
- Res : constant Match_Result :=
- Match_Value (Ctx, Pattern.As_Not_Pattern.F_Pattern, Value);
- begin
- if Res.Is_Success then
- return Match_Failure;
- else
- return Make_Match_Success (Value);
- end if;
- end;
-
- when LCO.Lkql_Node_Pattern =>
- if not (Kind (Value) = Kind_Node) then
- Raise_Invalid_Kind
- (Ctx, Pattern.As_Lkql_Node, Kind_Node, Value);
- end if;
-
- return Match_Node_Pattern
- (Ctx, Pattern.As_Node_Pattern, Node_Val (Value));
-
- when LCO.Lkql_Universal_Pattern =>
- return Make_Match_Success (Value);
-
- when LCO.Lkql_Regex_Pattern =>
- return Match_Regex
- (Ctx, Pattern.As_Regex_Pattern, Value);
-
- when LCO.Lkql_Null_Pattern =>
- if Value.Node_Val.Is_Null then
- return Make_Match_Success (Value);
- else
- return Match_Failure;
- end if;
-
- when others =>
- raise Assertion_Error with
- "Invalid pattern kind: " & L.Kind_Name (Pattern);
- end case;
- end Match_Value;
-
- -------------------
- -- Match_Binding --
- -------------------
-
- function Match_Binding (Ctx : Eval_Context;
- Pattern : L.Binding_Pattern;
- Value : Primitive) return Match_Result
- is
- Binding_Name : constant Unbounded_Text_Type :=
- To_Unbounded_Text (Pattern.F_Binding.Text);
- begin
- Ctx.Add_Binding (To_Text (Binding_Name), Value);
-
- if Match_Value (Ctx, Pattern.F_Value_Pattern, Value).Is_Success
- then
- return Make_Match_Success (Value);
- else
- return Match_Failure;
- end if;
- end Match_Binding;
-
- -----------------
- -- Match_Regex --
- -----------------
-
- function Match_Regex (Ctx : Eval_Context;
- Pattern : L.Regex_Pattern;
- Value : Primitive) return Match_Result
- is
- pragma Unreferenced (Ctx);
-
- use LKQL.Node_Extensions;
-
- Pat_Ext : constant Ext := Get_Ext (Pattern);
- begin
- case Kind (Value) is
- when Kind_Node =>
- if not Value.Node_Val.Is_Null
- and then GNAT.Regpat.Match
- (Pat_Ext.Content.Compiled_Pattern.all,
- To_UTF8 (Value.Node_Val.Text))
- then
- return Make_Match_Success (Value);
- end if;
- when Kind_Str =>
- if GNAT.Regpat.Match
- (Pat_Ext.Content.Compiled_Pattern.all,
- To_UTF8 (Str_Val (Value)))
- then
- return Make_Match_Success (Value);
- end if;
- when others =>
- null;
- end case;
- return Match_Failure;
- end Match_Regex;
-end LKQL.Patterns.Match;
diff --git a/lkql/extensions/src/lkql-patterns-match.ads b/lkql/extensions/src/lkql-patterns-match.ads
deleted file mode 100644
index 62b791f9e..000000000
--- a/lkql/extensions/src/lkql-patterns-match.ads
+++ /dev/null
@@ -1,70 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-
-package LKQL.Patterns.Match is
-
- function Match_Pattern_Array (Ctx : Eval_Context;
- Patterns : L.Base_Pattern_Array;
- Value : Primitive)
- return Match_Array_Result;
- -- Match a value against an array of pattern.
- -- Return the index of the first successful match, along with the
- -- associated bindings, if any.
-
- function Match_Pattern (Ctx : Eval_Context;
- Pattern : L.Base_Pattern;
- Value : Primitive) return Match_Result;
- -- Match a Primitive value against the given pattern
-
- function Match_Unfiltered (Ctx : Eval_Context;
- Pattern : L.Unfiltered_Pattern;
- Value : Primitive) return Match_Result;
- -- Match a Primitive value against a pattern that doesn't contain a
- -- filtering predicate.
-
- function Match_Filtered (Ctx : Eval_Context;
- Pattern : L.Filtered_Pattern;
- Value : Primitive) return Match_Result;
- -- Match a Primitive value against a pattern that contains a filtering
- -- predicate.
-
- function Match_Value (Ctx : Eval_Context;
- Pattern : L.Value_Pattern;
- Value : Primitive) return Match_Result;
- -- Match a Primitive value against a value pattern, i.e a pattern that
- -- doesn't contain a binding name.
-
- function Match_Binding (Ctx : Eval_Context;
- Pattern : L.Binding_Pattern;
- Value : Primitive) return Match_Result;
- -- Match a Primitive value against a pattern that contains both a binding
- -- name and a value pattern.
-
- function Match_Regex (Ctx : Eval_Context;
- Pattern : L.Regex_Pattern;
- Value : Primitive) return Match_Result;
- -- Match a Primitive value against a regular expression.
-
-end LKQL.Patterns.Match;
diff --git a/lkql/extensions/src/lkql-patterns-nodes.adb b/lkql/extensions/src/lkql-patterns-nodes.adb
deleted file mode 100644
index 9eb9d4392..000000000
--- a/lkql/extensions/src/lkql-patterns-nodes.adb
+++ /dev/null
@@ -1,406 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Node_Data;
-with LKQL.Patterns.Match; use LKQL.Patterns.Match;
-with LKQL.Primitives; use LKQL.Primitives;
-with LKQL.Evaluation; use LKQL.Evaluation;
-with LKQL.Functions; use LKQL.Functions;
-with LKQL.Node_Extensions;
-with LKQL.Selector_Lists; use LKQL.Selector_Lists;
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-with Langkit_Support.Generic_API.Introspection;
-
-with Ada.Assertions; use Ada.Assertions;
-with LKQL.Error_Handling; use LKQL.Error_Handling;
-
-package body LKQL.Patterns.Nodes is
-
- ------------------------
- -- Filter_Node_Vector --
- ------------------------
-
- function Filter_Node_Vector
- (Ctx : Eval_Context;
- Pattern : L.Base_Pattern;
- Nodes : Lk_Node_Vector) return Lk_Node_Vector
- is
- Filtered : Lk_Node_Vector;
- begin
- for N of Nodes loop
- if Match_Pattern (Ctx, Pattern, To_Primitive (N, Ctx.Pool)).Is_Success
- then
- Filtered.Append (N);
- end if;
- end loop;
-
- return Filtered;
- end Filter_Node_Vector;
-
- ------------------------
- -- Match_Node_Pattern --
- ------------------------
-
- function Match_Node_Pattern
- (Ctx : Eval_Context;
- Pattern : L.Node_Pattern;
- Node : Lk_Node) return Match_Result
- is
- begin
- if Node.Is_Null then
- return Match_Failure;
- end if;
-
- case Pattern.Kind is
- when LCO.Lkql_Node_Kind_Pattern =>
- return Match_Kind_Pattern
- (Ctx, Pattern.As_Node_Kind_Pattern, Node);
- when LCO.Lkql_Extended_Node_Pattern =>
- return Match_Extended_Pattern
- (Ctx, Pattern.As_Extended_Node_Pattern, Node);
- when others =>
- raise Assertion_Error
- with "Invalid node pattern kind: " & L.Kind_Name (Pattern);
- end case;
- end Match_Node_Pattern;
-
- ------------------------
- -- Match_Kind_Pattern --
- ------------------------
-
- function Match_Kind_Pattern
- (Ctx : Eval_Context;
- Pattern : L.Node_Kind_Pattern;
- Node : Lk_Node) return Match_Result
- is
- Ext : constant Node_Extensions.Ext := Node_Extensions.Get_Ext (Pattern);
- Node_Val : constant Langkit_Support.Generic_API.Introspection.Value_Ref
- := LKI.From_Node (Ctx.Lang_Id, Node);
- begin
- return
- (if LKI.Type_Matches
- (Node_Val, Ext.Content.Expected_Type)
- then Make_Match_Success (To_Primitive (Node, Ctx.Pool))
- else Match_Failure);
- exception
- when E : Unsupported_Error =>
- Raise_From_Exception (Ctx, E, Pattern);
- end Match_Kind_Pattern;
-
- ----------------------------
- -- Match_Extended_Pattern --
- ----------------------------
-
- function Match_Extended_Pattern
- (Ctx : Eval_Context;
- Pattern : L.Extended_Node_Pattern;
- Node : LK.Lk_Node) return Match_Result
- is
- Match : constant Match_Result :=
- Match_Value
- (Ctx, Pattern.F_Node_Pattern, To_Primitive (Node, Ctx.Pool));
- Result : constant Match_Result :=
- (if Match.Is_Success
- then Match_Pattern_Details (Ctx, Pattern.F_Details, Node)
- else Match_Failure);
- begin
- return Result;
- end Match_Extended_Pattern;
-
- ---------------------------
- -- Match_Pattern_Details --
- ---------------------------
-
- function Match_Pattern_Details
- (Ctx : Eval_Context;
- Details : L.Node_Pattern_Detail_List;
- Node : LK.Lk_Node) return Match_Result
- is
- Current_Match : Match_Result;
- begin
- for D of Details loop
- Current_Match := Match_Pattern_Detail (Ctx, Node, D);
-
- if not Current_Match.Is_Success then
- return Match_Failure;
- end if;
-
- end loop;
-
- return Make_Match_Success (To_Primitive (Node, Ctx.Pool));
- end Match_Pattern_Details;
-
- --------------------------
- -- Match_Pattern_Detail --
- --------------------------
-
- function Match_Pattern_Detail
- (Ctx : Eval_Context;
- Node : LK.Lk_Node;
- Detail : L.Node_Pattern_Detail'Class) return Match_Result
- is
- begin
- case Detail.Kind is
- when LCO.Lkql_Node_Pattern_Field =>
- return Match_Pattern_Field
- (Ctx, Node, Detail.As_Node_Pattern_Field);
- when LCO.Lkql_Node_Pattern_Property =>
- return Match_Pattern_Property
- (Ctx, Node, Detail.As_Node_Pattern_Property);
- when LCO.Lkql_Node_Pattern_Selector =>
- return Match_Pattern_Selector
- (Ctx, Node, Detail.As_Node_Pattern_Selector);
- when others =>
- raise Assertion_Error
- with "Invalid pattern detail kind: " & L.Kind_Name (Detail);
- end case;
- end Match_Pattern_Detail;
-
- -------------------------
- -- Match_Pattern_Field --
- -------------------------
-
- function Match_Pattern_Field (Ctx : Eval_Context;
- Node : LK.Lk_Node;
- Field : L.Node_Pattern_Field)
- return Match_Result
- is
- use LKQL.Node_Data;
- Field_Value : constant Primitive :=
- Access_Node_Field (Ctx, Node, Field.F_Identifier);
- begin
- return Match_Detail_Value (Ctx, Field_Value, Field.F_Expected_Value);
- end Match_Pattern_Field;
-
- ----------------------------
- -- Match_Pattern_Property --
- ----------------------------
-
- function Match_Pattern_Property
- (Ctx : Eval_Context;
- Node : LK.Lk_Node;
- Property : L.Node_Pattern_Property) return Match_Result
- is
- use LKQL.Node_Data;
- Property_Value : constant Primitive :=
- Eval_Node_Property
- (Ctx, Node,
- Property.F_Call.F_Name.As_Identifier,
- Property.F_Call.F_Arguments);
- begin
- return Match_Detail_Value
- (Ctx, Property_Value, Property.F_Expected_Value);
- end Match_Pattern_Property;
-
- ----------------------------
- -- Match_Pattern_Selector --
- ----------------------------
-
- function Match_Pattern_Selector
- (Ctx : Eval_Context;
- Node : LK.Lk_Node;
- Selector : L.Node_Pattern_Selector) return Match_Result
- is
- S_List : Primitive;
- Binding_Name : constant Symbol_Type :=
- Symbol (Selector.F_Call.P_Binding_Name);
- begin
- if not Eval_Selector
- (Ctx, Node, Selector.F_Call, Selector.F_Pattern, S_List)
- then
- return Match_Failure;
- end if;
-
- if Binding_Name /= null then
- Ctx.Add_Binding (Binding_Name, S_List);
- end if;
-
- return Make_Match_Success (To_Primitive (Node, Ctx.Pool));
- end Match_Pattern_Selector;
-
- -------------------
- -- Eval_Selector --
- -------------------
-
- function Eval_Selector
- (Ctx : Eval_Context;
- Node : LK.Lk_Node;
- Call : L.Selector_Call;
- Pattern : L.Base_Pattern;
- Result : out Primitive) return Boolean
- is
- Quantifier_Name : constant String := To_UTF8 (Call.P_Quantifier_Name);
- Selector_Expr : constant L.Expr := Call.F_Selector_Call;
- Selector_Call : L.Fun_Call := L.No_Fun_Call;
- Selector : Primitive;
- Local_Ctx : constant Eval_Context := Ctx.Create_New_Frame;
- use L, LCO;
- begin
- -- TODO: For now LKQL supports calling selectors without parentheses
- -- when there are no arguments. We probably want to change that, see
- -- W104-009 for more details.
- --
- -- For now, the selector can be either a function call, in which case it
- -- is treated as the call to a selector, with the prefix designating the
- -- selector, or any other expression, in which case the expression must
- -- return the selector.
- if L.Kind (Selector_Expr) = LCO.Lkql_Fun_Call then
- Selector_Call := Selector_Expr.As_Fun_Call;
- Selector := Eval (Local_Ctx, Selector_Call.F_Name);
- else
- Selector := Eval (Local_Ctx, Selector_Expr);
- end if;
-
- -- Check that the kind of the entity is a selector
- if Kind (Selector) /= Kind_Selector then
- Raise_Invalid_Type
- (Local_Ctx, Selector_Expr.As_Lkql_Node, "selector", Selector);
- end if;
-
- declare
-
- Filtered_Iter : constant Depth_Node_Iter_Access :=
- new Depth_Node_Iters.Filter_Iter'
- (Depth_Node_Iters.Filter
- (Eval_User_Selector_Call
- (Local_Ctx, Selector_Call, Selector, Node),
- Make_Node_Pattern_Predicate (Local_Ctx, Pattern)));
- -- Then, we create a filtered iterator
-
- Res_List : Selector_List :=
- Make_Selector_List (Filtered_Iter);
- -- Create a selector list from the selector call
-
- function Has_Element return Boolean;
- -- Return whether ``Res_List`` has at least one element or not,
- -- consuming the whole list if necessary
-
- function Has_Element return Boolean is
- N : Depth_Node;
- begin
- -- NOTE: Calling `.Length` here will trigger evaluation of the
- -- underlying filtered iterator and save its content in the
- -- selector list. This is only necessary when the list is bound to
- -- a name, so that the content of the list is consistent
- -- regardless of the used quantifier.
- return (if not Call.F_Binding.Is_Null
- then Res_List.Length /= 0
- else Res_List.Next (N));
- end Has_Element;
-
- begin
- Result := To_Primitive (Res_List, Local_Ctx.Pool);
-
- if Quantifier_Name = "all" then
- declare
- Dummy : Natural := Res_List.Length;
- -- Trigger evaluation of the whole list, so that
- -- ``Filtered_Count`` is set to its right value below.
- begin
- return Depth_Node_Iters.Filter_Iter
- (Filtered_Iter.all).Filtered_Count = 0;
- end;
- elsif Quantifier_Name = "any" then
- return Has_Element;
- elsif Quantifier_Name = "no" then
- return not Has_Element;
- else
- raise Assertion_Error with
- "invalid quantifier name: " & Quantifier_Name;
- end if;
- end;
-
- end Eval_Selector;
-
- --------------
- -- Evaluate --
- --------------
-
- overriding function Evaluate
- (Self : in out Node_Pattern_Predicate; Node : Depth_Node) return Boolean
- is
- Result : constant Match_Result :=
- Match_Pattern
- (Self.Ctx, Self.Pattern, To_Primitive (Node.Node, Self.Ctx.Pool));
- begin
- return Result.Is_Success;
- end Evaluate;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone
- (Self : Node_Pattern_Predicate) return Node_Pattern_Predicate
- is
- begin
- return (Self.Ctx.Ref_Frame, Self.Pattern);
- end Clone;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Self : in out Node_Pattern_Predicate) is
- begin
- Self.Ctx.Release_Current_Frame;
- end Release;
-
- ---------------------------------
- -- Make_Node_Pattern_Predicate --
- ---------------------------------
-
- function Make_Node_Pattern_Predicate (Ctx : Eval_Context;
- Pattern : L.Base_Pattern)
- return Node_Pattern_Predicate
- is
- (Ctx.Ref_Frame, Pattern);
-
- ------------------------
- -- Match_Detail_Value --
- ------------------------
-
- function Match_Detail_Value (Ctx : Eval_Context;
- Value : Primitive;
- Detail : L.Detail_Value) return Match_Result
- is
- use LCO;
- begin
- if Detail.Kind = Lkql_Detail_Expr then
- declare
- Detail_Value : constant Primitive :=
- Eval (Ctx, Detail.As_Detail_Expr.F_Expr_Value,
- Expected_Kind => Kind (Value));
- begin
- return (if Deep_Equals (Value, Detail_Value)
- then Make_Match_Success (Value)
- else Match_Failure);
- end;
- else
- return Match_Pattern
- (Ctx, Detail.As_Detail_Pattern.F_Pattern_Value, Value);
- end if;
- end Match_Detail_Value;
-
-end LKQL.Patterns.Nodes;
diff --git a/lkql/extensions/src/lkql-patterns-nodes.ads b/lkql/extensions/src/lkql-patterns-nodes.ads
deleted file mode 100644
index 82e74de53..000000000
--- a/lkql/extensions/src/lkql-patterns-nodes.ads
+++ /dev/null
@@ -1,141 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Depth_Nodes; use LKQL.Depth_Nodes;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-
-package LKQL.Patterns.Nodes is
-
- function Filter_Node_Vector
- (Ctx : Eval_Context;
- Pattern : L.Base_Pattern;
- Nodes : Lk_Node_Vector) return Lk_Node_Vector;
- -- Return a node array that only contains the nodes from 'Nodes' that match
- -- 'Pattern'.
-
- function Match_Node_Pattern
- (Ctx : Eval_Context;
- Pattern : L.Node_Pattern;
- Node : Lk_Node) return Match_Result;
- -- Match the given node against a node pattern
-
- function Match_Kind_Pattern
- (Ctx : Eval_Context;
- Pattern : L.Node_Kind_Pattern;
- Node : Lk_Node) return Match_Result
- with Pre => not Node.Is_Null;
- -- Match th given node against a kind pattern
-
- function Match_Extended_Pattern (Ctx : Eval_Context;
- Pattern : L.Extended_Node_Pattern;
- Node : Lk_Node)
- return Match_Result
- with Pre => not Node.Is_Null;
- -- Match the given node against an extended pattern
-
- function Match_Pattern_Details (Ctx : Eval_Context;
- Details : L.Node_Pattern_Detail_List;
- Node : Lk_Node)
- return Match_Result
- with Pre => not Node.Is_Null;
- -- Match a given node against the 'details' (fields, properties &
- -- selectors) of a node pattern.
- -- The 'Bindings' part of the Match result will contain references to the
- -- selector lists that are associated with a binding name in the pattern.
-
- function Match_Pattern_Detail (Ctx : Eval_Context;
- Node : Lk_Node;
- Detail : L.Node_Pattern_Detail'Class)
- return Match_Result
- with Pre => not Node.Is_Null;
- -- Match 'Node' against a node pattern 'detail'
-
- function Match_Pattern_Field (Ctx : Eval_Context;
- Node : Lk_Node;
- Field : L.Node_Pattern_Field)
- return Match_Result
- with Pre => not Node.Is_Null;
- -- Match the expected value specified in 'Field' against the value of the
- -- field of 'Node' designated by 'Field'.
-
- function Match_Pattern_Property (Ctx : Eval_Context;
- Node : Lk_Node;
- Property : L.Node_Pattern_Property)
- return Match_Result
- with Pre => not Node.Is_Null;
- -- Match the expected value specified in 'Property' against the value of
- -- the property call described in 'Property' on 'Node'.
-
- function Match_Pattern_Selector (Ctx : Eval_Context;
- Node : Lk_Node;
- Selector : L.Node_Pattern_Selector)
- return Match_Result
- with Pre => not Node.Is_Null;
- -- Match 'Node' against a selector appearing as a node pattern detail.
- -- If the selector has a binding name, a binding associating the said name
- -- to the output of the selector will be added to the 'Bindings' part of
- -- the 'Match_Result'.
-
- function Eval_Selector (Ctx : Eval_Context;
- Node : Lk_Node;
- Call : L.Selector_Call;
- Pattern : L.Base_Pattern;
- Result : out Primitive) return Boolean;
- -- Return whether the evaluation of the given selector from 'Node' produces
- -- a valid result.
- -- If that is the case, the associated selector_list will be stored in
- -- 'Result'.
-
- -----------------------------
- -- Node_Pattern_Predicate --
- -----------------------------
-
- type Node_Pattern_Predicate is new Depth_Node_Iters.Predicates.Func with
- record
- Ctx : Eval_Context;
- Pattern : L.Base_Pattern;
- end record;
- -- Predicate that returns true when given a Depth_Node that matches
- -- 'Pattern'.
-
- overriding function Evaluate
- (Self : in out Node_Pattern_Predicate; Node : Depth_Node) return Boolean;
-
- overriding function Clone
- (Self : Node_Pattern_Predicate) return Node_Pattern_Predicate;
-
- overriding procedure Release (Self : in out Node_Pattern_Predicate);
-
- function Make_Node_Pattern_Predicate (Ctx : Eval_Context;
- Pattern : L.Base_Pattern)
- return Node_Pattern_Predicate;
- -- Create a Node_Pattern_Predicate with the given pattern and evaluation
- -- context.
-
-private
-
- function Match_Detail_Value (Ctx : Eval_Context;
- Value : Primitive;
- Detail : L.Detail_Value) return Match_Result;
-
-end LKQL.Patterns.Nodes;
diff --git a/lkql/extensions/src/lkql-patterns.adb b/lkql/extensions/src/lkql-patterns.adb
deleted file mode 100644
index 577029cb4..000000000
--- a/lkql/extensions/src/lkql-patterns.adb
+++ /dev/null
@@ -1,50 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package body LKQL.Patterns is
-
- ----------------
- -- Is_Success --
- ----------------
-
- function Is_Success (Self : Match_Result) return Boolean is
- (Is_Some (Self.Matched_Value));
-
- -----------------------
- -- Get_Matched_Value --
- -----------------------
-
- function Get_Matched_Value (Self : Match_Result) return Primitive is
- (Extract (Self.Matched_Value));
-
- ------------------------
- -- Make_Match_Success --
- ------------------------
-
- function Make_Match_Success
- (Matched_Value : Primitive)
- return Match_Result
- is
- (Match_Result'(Matched_Value => To_Option (Matched_Value)));
-
-end LKQL.Patterns;
diff --git a/lkql/extensions/src/lkql-patterns.ads b/lkql/extensions/src/lkql-patterns.ads
deleted file mode 100644
index a639110e0..000000000
--- a/lkql/extensions/src/lkql-patterns.ads
+++ /dev/null
@@ -1,65 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Primitives; use LKQL.Primitives;
-
-private package LKQL.Patterns is
-
- use Primitive_Options;
-
- type Match_Result is tagged record
- Matched_Value : Primitive_Option;
- -- True if the matching attempt succeeded
- end record;
- -- Represents that result of a matching attempt
-
- function Make_Match_Success
- (Matched_Value : Primitive)
- return Match_Result;
- -- Create a Match_Result value representing a successful matching attempt
- -- with the given binding(s).
-
- function Is_Success (Self : Match_Result) return Boolean;
- -- Return whether the match was successful
-
- function Get_Matched_Value (Self : Match_Result) return Primitive
- with Pre => Self.Is_Success;
- -- If the match was successful, return the matched value.
- -- Otherwise, raise an exception.
-
- Match_Failure : constant Match_Result :=
- Match_Result'(Matched_Value => None);
- -- Special value representing the failure of a matching attempt
-
- subtype Match_Index is Integer range Positive'First - 1 .. Positive'Last;
-
- type Match_Array_Result is record
- Matched_Value : Primitive_Option;
- -- If the match was successful, stores the matched value
- Index : Match_Index := Match_Index'First;
- -- Index of the first matched pattern
- end record;
- -- Represents the result of a matching attempt against a sequence of
- -- patterns.
-
-end LKQL.Patterns;
diff --git a/lkql/extensions/src/lkql-primitives.adb b/lkql/extensions/src/lkql-primitives.adb
deleted file mode 100644
index 56262535e..000000000
--- a/lkql/extensions/src/lkql-primitives.adb
+++ /dev/null
@@ -1,1688 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Assertions; use Ada.Assertions;
-with Ada.Containers; use type Ada.Containers.Count_Type;
-with Ada.Containers.Generic_Array_Sort;
-with Ada.Directories;
-with Ada.Strings.Wide_Wide_Unbounded; use Ada.Strings.Wide_Wide_Unbounded;
-with Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO;
-use Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO;
-with Ada.Wide_Wide_Text_IO;
-with Ada.Strings.Hash;
-
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with LKQL.Evaluation;
-with LKQL.Error_Handling; use LKQL.Error_Handling;
-with LKQL.Errors; use LKQL.Errors;
-
-with Langkit_Support.Hashes; use Langkit_Support.Hashes;
-with Langkit_Support.Names; use Langkit_Support.Names;
-
-with GNAT.Case_Util;
-
-with LKQL.Depth_Nodes;
-
-package body LKQL.Primitives is
-
- function Int_Image (Value : Adaptive_Integer) return Unbounded_Text_Type;
- -- Wraps the Integer'Wide_Wide_Image function, removing the leading space
-
- function Bool_Image (Value : Boolean) return Unbounded_Text_Type;
- -- Return a String representation of the given Boolean value
-
- function Iterator_Image
- (Value : Primitive) return Unbounded_Text_Type;
-
- function Selector_List_Image
- (Value : Selector_List) return Unbounded_Text_Type;
- -- Return a String representation of the given Selector_List
-
- function List_Image (Value : Primitive_List;
- Open : Text_Type := "[";
- Close : Text_Type := "]") return Unbounded_Text_Type;
- -- Return a String representation of the given Primitive_List value
-
- function Object_Image (Value : Primitive_Assocs) return Unbounded_Text_Type;
- -- Given a ``Primitive_Assocs``, return a textual representation as ``{key:
- -- , ...}``.
-
- function Selector_List_Data (Value : Selector_List;
- Member_Name : Text_Type;
- Pool : Primitive_Pool) return Primitive;
- -- Return the value of the property named 'Member_Name' of the given
- -- Primitive Selector_List.
- -- Raise an Unsupported_Error if there is no property named
- -- 'Member_Name'.
-
- function List_Data (Value : Primitive_List_Access;
- Member_Name : Text_Type;
- Pool : Primitive_Pool) return Primitive;
- -- Return the value of the property named 'Member_Name' of the given
- -- Primitive List.
- -- Raise an Unsupported_Error if there is no property named
- -- 'Member_Name'.
-
- function Str_Data
- (Value : Text_Type;
- Member_Name : Text_Type;
- Pool : Primitive_Pool) return Primitive;
- -- Return the value of the property named 'Member_Name' of the given
- -- Str value.
- -- Raise an Unsupported_Error if there is no property named
- -- 'Member_Name'.
-
- procedure Raise_Unsupported_Operation
- (Left, Right : Primitive; Name : String)
- with No_Return;
- -- Raise an Unsupported_Operation exception mentionning the kind of the
- -- operands as well as the name of the operation.
-
- function Create return Primitive_Pool;
- -- Create a new primitive pool
-
- procedure Destroy (Pool : in out Primitive_Pool);
- -- Destroy the pool (free all the objects, and free the pool)
-
- ---------------
- -- Int_Image --
- ---------------
-
- function Int_Image (Value : Adaptive_Integer) return Unbounded_Text_Type is
- Image : constant Text_Type := To_Text (Adaptive_Integers.Image (Value));
- begin
- if Image (1) = ' ' then
- return To_Unbounded_Text (Image (2 .. Image'Last));
- else
- return To_Unbounded_Text (Image);
- end if;
- end Int_Image;
-
- -----------------
- -- Bool_Image --
- -----------------
-
- function Bool_Image (Value : Boolean) return Unbounded_Text_Type is
- use GNAT.Case_Util;
- Image : String := Boolean'Image (Value);
- begin
- To_Lower (Image);
- return To_Unbounded_Text (To_Text (Image));
- end Bool_Image;
-
- -------------------------
- -- Selector_List_Image --
- -------------------------
-
- function Selector_List_Image
- (Value : Selector_List) return Unbounded_Text_Type
- is
- use LKQL.Depth_Nodes;
- Image : Unbounded_Text_Type;
- Nodes : constant Depth_Node_Vector := Value.Depth_Nodes;
- Length : constant Count_Type := Nodes.Length;
- Counter : Count_Type := 1;
- begin
- Append (Image, "[");
-
- for D of Nodes loop
- Counter := Counter + 1;
- Append (Image, To_Text (D.Node.Image));
- if Counter <= Length then
- Append (Image, ", ");
- end if;
- end loop;
-
- Append (Image, "]");
-
- return Image;
- end Selector_List_Image;
-
- ----------------
- -- List_Image --
- ----------------
-
- function List_Image (Value : Primitive_List;
- Open : Text_Type := "[";
- Close : Text_Type := "]") return Unbounded_Text_Type
- is
- Image : Unbounded_Text_Type;
- begin
- Append (Image, Open);
-
- for I in Value.Elements.First_Index .. Value.Elements.Last_Index loop
- Append (Image, To_Unbounded_Text (Value.Elements (I)));
-
- if I < Value.Elements.Last_Index then
- Append (Image, ", ");
- end if;
- end loop;
-
- Append (Image, Close);
-
- return Image;
- end List_Image;
-
- ------------------
- -- Object_Image --
- ------------------
-
- function Object_Image (Value : Primitive_Assocs) return Unbounded_Text_Type
- is
- Image : Unbounded_Text_Type;
- use Primitive_Maps;
- begin
- Append (Image, "{");
-
- declare
- type Cursor_Array
- is array (Positive range <>) of Primitive_Maps.Cursor;
-
- Cursors : Cursor_Array (1 .. Natural (Value.Elements.Length));
-
- function "<" (L, R : Primitive_Maps.Cursor) return Boolean
- is
- (Key (L).all < Key (R).all);
-
- procedure Cursor_Sort
- is new Ada.Containers.Generic_Array_Sort
- (Positive, Primitive_Maps.Cursor, Cursor_Array, "<");
-
- I : Positive := 1;
- begin
- for Cur in Value.Elements.Iterate loop
- Cursors (I) := Cur;
- I := I + 1;
- end loop;
-
- Cursor_Sort (Cursors);
-
- I := 1;
-
- for Cur of Cursors loop
- Append (Image, """" & Key (Cur).all & """");
- Append (Image, ": ");
- Append (Image, To_Unbounded_Text (Primitive_Maps.Element (Cur)));
- if I < Positive (Value.Elements.Length) then
- Append (Image, ", ");
- end if;
- I := I + 1;
- end loop;
- end;
-
- Append (Image, "}");
- return Image;
- end Object_Image;
-
- --------------------
- -- Iterator_Image --
- --------------------
-
- function Iterator_Image
- (Value : Primitive) return Unbounded_Text_Type
- is
- begin
- Consume (Value);
- return List_Image (Value.Iter_Cache.all);
- end Iterator_Image;
-
- ----------------
- -- Check_Kind --
- ----------------
-
- procedure Check_Kind
- (Expected_Kind : Valid_Primitive_Kind; Value : Primitive) is
- begin
- if Kind (Value) /= Expected_Kind then
- raise Unsupported_Error
- with "Type error: expected " &
- To_String (Expected_Kind) & " but got " &
- Kind_Name (Value);
- end if;
- end Check_Kind;
-
- ---------------------------------
- -- Raise_Unsupported_Operation --
- ---------------------------------
-
- procedure Raise_Unsupported_Operation
- (Left, Right : Primitive; Name : String)
- is
- Message : constant String :=
- "Unsupported operation: " & Kind_Name (Left) & ' ' & Name &
- Kind_Name (Right);
- begin
- raise Unsupported_Error with Message;
- end Raise_Unsupported_Operation;
-
- -------------
- -- Release --
- -------------
-
- procedure Release (Data : in out Primitive_Data) is
- procedure Free_Regex is new Ada.Unchecked_Deallocation
- (GNAT.Regpat.Pattern_Matcher, Regex_Access);
- begin
- case Data.Kind is
- when Kind_List =>
- Free_Primitive_List (Data.List_Val);
- when Kind_Iterator =>
- Data.Iter_Val.Iter.Release;
- Primitive_Iters.Free_Iterator (Data.Iter_Val.Iter);
- Free_Iterator_Primitive (Data.Iter_Val);
- Free_Primitive_List (Data.Iter_Cache);
- when Kind_Function | Kind_Selector =>
- LKQL.Eval_Contexts.Dec_Ref
- (LKQL.Eval_Contexts.Environment_Access (Data.Frame));
- when Kind_Str =>
- Free (Data.Str_Val);
- when Kind_Namespace =>
- LKQL.Eval_Contexts.Dec_Ref
- (LKQL.Eval_Contexts.Environment_Access (Data.Namespace));
- when Kind_Object =>
- Free_Primitive_Assocs (Data.Obj_Assocs);
- when Kind_Builtin_Function =>
- -- We don't ever free built-in functions, since their data is
- -- freed directly in the builtin functions package.
- null;
- when Kind_Regex =>
- Free_Regex (Data.Regex_Val);
- when others =>
- null;
- end case;
- end Release;
-
- --------------
- -- Get_Iter --
- --------------
-
- function Get_Iter (Value : Iterator_Primitive) return Primitive_Iter_Access
- is
- begin
- return new Primitive_Iters.Iterator_Interface'Class'
- (Primitive_Iters.Iterator_Interface'Class (Value.Iter.Clone));
- end Get_Iter;
-
- -------------
- -- Consume --
- -------------
-
- procedure Consume (Iter : Primitive; Num_Elements : Integer := -1)
- is
- Element : Primitive;
- Consumed : Natural := 0;
- begin
- while (Num_Elements = -1 or else Consumed < Num_Elements)
- and then Iter.Iter_Val.Iter.Next (Element)
- loop
- Iter.Iter_Cache.Elements.Append (Element);
- Consumed := Consumed + 1;
- end loop;
- end Consume;
-
- -----------------
- -- To_Iterator --
- -----------------
-
- function To_Iterator
- (Value : Primitive; Pool : Primitive_Pool) return Primitive_Iter'Class
- is
- (case Value.Kind is
- when Kind_Iterator =>
- Primitive_Iter'Class (Iter_Val (Value).Iter.Clone),
- when Kind_List =>
- Primitive_Vec_Iters.To_Iterator (Elements (Value).all),
- when Kind_Selector_List =>
- To_Iterator (To_List (Selector_List_Val (Value), Pool), Pool),
- when others =>
- raise Assertion_Error with
- "Cannot get an iterator from a value of kind : " &
- Kind_Name (Value));
-
- -------------
- -- To_List --
- -------------
-
- function To_List
- (Value : Selector_List; Pool : Primitive_Pool) return Primitive
- is
- begin
- return Result : constant Primitive := Make_Empty_List (Pool) do
- for N of Value.Nodes loop
- Append (Result, To_Primitive (N, Pool));
- end loop;
- end return;
- end To_List;
-
- ----------
- -- Kind --
- ----------
-
- function Kind (Value : Primitive) return Valid_Primitive_Kind is
- (Value.Kind);
-
- -------------
- -- Int_Val --
- -------------
-
- function Int_Val (Value : Primitive) return Adaptive_Integer is
- (Value.Int_Val);
-
- -------------
- -- Str_Val --
- -------------
-
- function Str_Val (Value : Primitive) return Text_Type is
- (Value.Str_Val.all);
-
- --------------
- -- Bool_Val --
- --------------
-
- function Bool_Val (Value : Primitive) return Boolean is
- (Value.Bool_Val);
-
- --------------
- -- Node_Val --
- --------------
-
- function Node_Val (Value : Primitive) return LK.Lk_Node is
- (Value.Node_Val);
-
- --------------
- -- List_Val --
- --------------
-
- function List_Val (Value : Primitive) return Primitive_List_Access is
- (Value.List_Val);
-
- -----------------------
- -- Selector_List_Val --
- -----------------------
-
- function Selector_List_Val (Value : Primitive) return Selector_List is
- (Value.Selector_List_Val);
-
- --------------
- -- Iter_Val --
- --------------
-
- function Iter_Val (Value : Primitive) return Iterator_Primitive_Access is
- (Value.Iter_Val);
-
- --------------
- -- Elements --
- --------------
-
- function Elements
- (Value : Primitive) return not null Primitive_Vector_Access is
- begin
- case Value.Kind is
- when Kind_List =>
- return Value.List_Val.Elements'Access;
- when Kind_Iterator =>
- Consume (Value);
- return Value.Iter_Cache.Elements'Access;
- when others =>
- raise Unsupported_Error with "Invalid kind for elements";
- end case;
- end Elements;
-
- ------------------------
- -- Selector_List_Data --
- ------------------------
-
- function Selector_List_Data
- (Value : Selector_List;
- Member_Name : Text_Type;
- Pool : Primitive_Pool) return Primitive
- is
- begin
- if Member_Name = "max_depth" then
- return To_Primitive (Value.Max_Depth, Pool);
- elsif Member_Name = "nodes" then
- return To_List (Value, Pool);
- else
- return List_Data
- (List_Val (To_List (Value, Pool)), Member_Name, Pool);
- end if;
-
- exception
- when Unsupported_Error =>
- raise Unsupported_Error with
- "No property named " & To_UTF8 (Member_Name) &
- " on values of kind " & To_String (Kind_Selector_List);
- end Selector_List_Data;
-
- ---------------
- -- List_Data --
- ---------------
-
- function List_Data (Value : Primitive_List_Access;
- Member_Name : Text_Type;
- Pool : Primitive_Pool) return Primitive
- is
- begin
- if Member_Name = "length" then
- return To_Primitive (Integer (Value.Elements.Length), Pool);
- else
- raise Unsupported_Error with
- "No property named " & To_UTF8 (Member_Name) &
- " on values of kind " & To_String (Kind_List);
- end if;
- end List_Data;
-
- ------------------
- -- Str_Property --
- ------------------
-
- function Str_Data
- (Value : Text_Type;
- Member_Name : Text_Type;
- Pool : Primitive_Pool) return Primitive
- is
- begin
- if Member_Name = "length" then
- return To_Primitive (Value'Length, Pool);
- else
- raise Unsupported_Error with
- "No property named " & To_UTF8 (Member_Name) &
- " on values of kind " & To_String (Kind_Str);
- end if;
- end Str_Data;
-
- --------------
- -- Property --
- --------------
-
- function Data
- (Value : Primitive;
- Member_Name : Text_Type;
- Pool : Primitive_Pool) return Primitive
- is
- begin
- case Kind (Value) is
- when Kind_Selector_List =>
- return Selector_List_Data
- (Selector_List_Val (Value), Member_Name, Pool);
- when Kind_List =>
- return List_Data (List_Val (Value), Member_Name, Pool);
- when Kind_Str =>
- return Str_Data (Str_Val (Value), Member_Name, Pool);
- when Kind_Iterator =>
- Consume (Value);
- return List_Data (Value.Iter_Cache, Member_Name, Pool);
- when others =>
- raise Unsupported_Error with
- "Cannot get property on value of kind "
- & Kind_Name (Value);
- end case;
- end Data;
-
- ----------------
- -- Is_Nullish --
- ----------------
-
- function Is_Nullish (Value : Primitive) return Boolean
- is
- ((Kind (Value) = Kind_Node
- and then Value.Node_Val.Is_Null)
- or else Kind (Value) = Kind_Unit);
-
- ----------------
- -- Booleanize --
- ----------------
-
- function Booleanize (Value : Primitive) return Boolean is
- begin
- return (if (Value.Kind = Kind_Bool
- and then not Value.Bool_Val)
- or else Value.Kind = Kind_Unit
- or else (Value.Kind = Kind_Node
- and then Value.Node_Val.Is_Null)
- then False
- else True);
- end Booleanize;
-
- ------------
- -- Truthy --
- ------------
-
- function Truthy (Value : Primitive; Has_Truthy : out Boolean) return Boolean
- is
- begin
- Has_Truthy := True;
-
- case Kind (Value) is
- when Kind_Node | Kind_Unit =>
- return Booleanize (Value);
- when Kind_Bool =>
- return Bool_Val (Value);
- when Kind_Iterator =>
- declare
- Iterator_Clone : Primitive_Iters.Iterator_Interface'Class
- := Primitive_Iters.Clone (Iter_Val (Value).Iter.all);
- Dummy_Element : Primitive;
- begin
- return Primitive_Iters.Next (Iterator_Clone, Dummy_Element);
- end;
- when Kind_List =>
- return Primitives.Length (Value) /= 0;
- when others =>
- Has_Truthy := False;
- return False;
- end case;
- end Truthy;
-
- ------------------
- -- To_Primitive --
- ------------------
-
- function To_Primitive
- (Val : Integer; Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive
- ((Kind => Kind_Int, Int_Val => Create (Val), Pool => Pool));
- end To_Primitive;
-
- ------------------
- -- To_Primitive --
- ------------------
- --
- function To_Primitive
- (Val : Adaptive_Integer; Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive
- ((Kind => Kind_Int, Int_Val => Val, Pool => Pool));
- end To_Primitive;
-
- ------------------
- -- To_Primitive --
- ------------------
-
- function To_Primitive
- (Val : Text_Type; Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive
- ((Kind => Kind_Str, Str_Val => new Text_Type'(Val), Pool => Pool));
- end To_Primitive;
-
- ------------------
- -- To_Primitive --
- ------------------
-
- function To_Primitive
- (Node : LK.Lk_Node; Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive ((Kind_Node, Pool, Node));
- end To_Primitive;
-
- ------------------
- -- To_Primitive --
- ------------------
-
- function To_Primitive
- (Token : LK.Lk_Token; Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive ((Kind_Token, Pool, Token));
- end To_Primitive;
-
- ------------------
- -- To_Primitive --
- ------------------
-
- function To_Primitive
- (Unit : LK.Lk_Unit; Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive ((Kind_Analysis_Unit, Pool, Unit));
- end To_Primitive;
-
- ------------------
- -- To_Primitive --
- ------------------
-
- function To_Primitive
- (Val : Primitive_Iter'Class; Pool : Primitive_Pool) return Primitive
- is
- Val_Copy : constant Primitive_Iter_Access :=
- new Primitive_Iter'Class'(Primitive_Iter'Class (Val.Clone));
-
- Iter_Primitive : constant Iterator_Primitive_Access :=
- new Iterator_Primitive'(Iter => Val_Copy);
-
- List : constant Primitive_List_Access :=
- new Primitive_List'(Elements => Primitive_Vectors.Empty_Vector);
- begin
- return Create_Primitive
- ((Kind_Iterator, Pool, Iter_Primitive, Iter_Cache => List));
- end To_Primitive;
-
- ------------------
- -- To_Primitive --
- ------------------
-
- function To_Primitive
- (Val : Selector_List; Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive ((Kind_Selector_List, Pool, Val));
- end To_Primitive;
-
- -----------------------
- -- Make_Empty_Object --
- -----------------------
-
- function Make_Empty_Object (Pool : Primitive_Pool) return Primitive is
- Map : constant Primitive_Assocs_Access :=
- new Primitive_Assocs'(Elements => Primitive_Maps.Empty_Map);
- begin
- return Create_Primitive
- ((Kind => Kind_Object, Obj_Assocs => Map, Pool => Pool));
- end Make_Empty_Object;
-
- ---------------------
- -- Make_Empty_List --
- ---------------------
-
- function Make_Empty_List (Pool : Primitive_Pool) return Primitive is
- List : constant Primitive_List_Access :=
- new Primitive_List'(Elements => Primitive_Vectors.Empty_Vector);
- begin
- return Create_Primitive
- ((Kind => Kind_List, List_Val => List, Pool => Pool));
- end Make_Empty_List;
-
- ----------------------
- -- Make_Empty_Tuple --
- ----------------------
-
- function Make_Empty_Tuple (Pool : Primitive_Pool) return Primitive is
- List : constant Primitive_List_Access :=
- new Primitive_List'(Elements => Primitive_Vectors.Empty_Vector);
- begin
- return Create_Primitive
- ((Kind => Kind_Tuple, List_Val => List, Pool => Pool));
- end Make_Empty_Tuple;
-
- --------------------
- -- Make_Namespace --
- --------------------
-
- function Make_Namespace
- (N : Environment_Access;
- Module : L.Lkql_Node;
- Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive
- ((Kind => Kind_Namespace,
- Namespace => N,
- Module => Module,
- Pool => Pool));
- end Make_Namespace;
-
- ----------------
- -- Make_Regex --
- ----------------
-
- function Make_Regex
- (Regex : GNAT.Regpat.Pattern_Matcher;
- Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive
- ((Kind => Kind_Regex,
- Regex_Val => new GNAT.Regpat.Pattern_Matcher'(Regex),
- Pool => Pool));
- end Make_Regex;
-
- -------------------
- -- Make_Function --
- -------------------
-
- function Make_Function
- (Node : L.Base_Function;
- Env : Environment_Access;
- Pool : Primitive_Pool;
- With_Call_Cache : Boolean := False) return Primitive is
- begin
- return Create_Primitive
- ((Kind => Kind_Function,
- Fun_Node => Node,
- Frame => Env,
- Pool => Pool,
- Call_Cache => (if With_Call_Cache
- then Callable_Caches.Create (Pool)
- else Callable_Caches.No_Cache)));
- end Make_Function;
-
- -----------------------------
- -- Make_Property_Reference --
- -----------------------------
-
- function Make_Property_Reference
- (Node_Val : LK.Lk_Node;
- Property_Ref : LKI.Struct_Member_Ref;
- Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive
- ((Kind => Kind_Property_Reference,
- Ref => Property_Ref,
- Property_Node => Node_Val,
- Pool => Pool));
- end Make_Property_Reference;
-
- -------------
- -- Profile --
- -------------
-
- function Profile (Obj : Primitive) return Text_Type is
- Profile : Unbounded_Text_Type;
- begin
- case Obj.Kind is
- when Kind_Function =>
- Profile := To_Unbounded_Text
- (Obj.Fun_Node.P_Profile);
- when Kind_Selector =>
- Profile := To_Unbounded_Text
- ("selector " & Obj.Sel_Node.F_Name.Text);
- when Kind_Builtin_Function =>
- declare
- P : constant Builtin_Function := Obj.Builtin_Fn;
- package U renames Ada.Strings.Wide_Wide_Unbounded;
- begin
- U.Append (Profile, "@builtin fun ");
- U.Append (Profile, P.Name);
- U.Append (Profile, "(");
- for I in P.Params'Range loop
- U.Append (Profile, P.Params (I).Name);
-
- if Primitive_Options.Is_Some (P.Params (I).Default_Value)
- then
- U.Append
- (Profile,
- "=" & To_Unbounded_Text
- (Primitive_Options.Extract
- (P.Params (I).Default_Value)));
- end if;
-
- if I < P.Params'Last then
- U.Append (Profile, ", ");
- end if;
- end loop;
- U.Append (Profile, ")");
- end;
- when others =>
- null;
- end case;
- return To_Text (Profile);
- end Profile;
-
- ---------------------------
- -- Make_Builtin_Function --
- ---------------------------
-
- function Make_Builtin_Function
- (Fn : Builtin_Function; Pool : Primitive_Pool) return Primitive
- is
- begin
- return Create_Primitive ((Kind_Builtin_Function, Pool, Fn));
- end Make_Builtin_Function;
-
- -------------------
- -- Make_Selector --
- -------------------
-
- function Make_Selector
- (Node : L.Selector_Decl;
- Env : Environment_Access;
- Pool : Primitive_Pool;
- With_Call_Cache : Boolean := False) return Primitive
- is
- begin
- return Create_Primitive
- ((Kind => Kind_Selector,
- Sel_Node => Node,
- Frame => Env,
- Pool => Pool,
- Sel_Cache => (if With_Call_Cache
- then new Node_To_Nodes.Map
- else null)));
- end Make_Selector;
-
- ------------
- -- Append --
- ------------
-
- procedure Append (List, Element : Primitive) is
- List_Elements : constant Primitive_Vector_Access :=
- Elements (List);
- begin
- Check_Kind (Kind_List, List);
- List_Elements.Append (Element);
- end Append;
-
- procedure Extend_With_List (List : Primitive_List_Access;
- New_values : Primitive_List_Access);
-
- procedure Extend_With_Iter (List : Primitive_List_Access;
- Iter : Iterator_Primitive_Access);
-
- ------------
- -- Extend --
- ------------
-
- procedure Extend (List, New_Value : Primitive) is
- begin
- Check_Kind (Kind_List, List);
-
- case Kind (New_Value) is
- when Kind_List =>
- Extend_With_List (List_Val (List), List_Val (New_Value));
- when Kind_Iterator =>
- Extend_With_Iter (List_Val (List), Iter_Val (New_Value));
- when others =>
- Append (List, New_Value);
- end case;
- end Extend;
-
- ----------------------
- -- Extend_With_List --
- ----------------------
-
- procedure Extend_With_List (List : Primitive_List_Access;
- New_values : Primitive_List_Access)
- is
- begin
- for E of New_values.Elements loop
- List.Elements.Append (E);
- end loop;
- end Extend_With_List;
-
- ----------------------
- -- Extend_With_Iter --
- ----------------------
-
- procedure Extend_With_Iter (List : Primitive_List_Access;
- Iter : Iterator_Primitive_Access)
- is
- Iter_Copy : Primitive_Iter'Class :=
- Iter.Iter.Clone;
- Current_Element : Primitive;
- begin
- while Iter_Copy.Next (Current_Element) loop
- List.Elements.Append (Current_Element);
- end loop;
-
- Iter_Copy.Release;
- end Extend_With_Iter;
-
- --------------
- -- Contains --
- --------------
-
- function Contains
- (List, Value : Primitive) return Boolean
- is
- begin
- Check_Kind (Kind_List, List);
-
- -- Since we're using smart pointers, the "=" function used by
- -- Vector.Contains checks referencial equality instead of structural
- -- equality. So the iteration "has" to be done manually.
- for Elem of List.List_Val.Elements loop
- if Deep_Equals (Elem, Value) then
- return True;
- end if;
- end loop;
-
- return False;
- end Contains;
-
- ---------
- -- Get --
- ---------
-
- function Get
- (List : Primitive; Index : Integer;
- Raise_If_OOB : Boolean := True) return Primitive
- is
- begin
- return Get (List.List_Val, Index, Raise_If_OOB);
- end Get;
-
- function Get
- (List : Primitive_List_Access; Index : Integer;
- Raise_If_OOB : Boolean := True) return Primitive
- is
- begin
- if Index not in List.Elements.First_Index .. List.Elements.Last_Index
- then
- if Raise_If_OOB then
- raise Unsupported_Error
- with "Invalid index:" &
- (if Index < 0 then " " else "") &
- Integer'Image (Index);
- else
- return Make_Unit_Primitive;
- end if;
-
- end if;
-
- return List.Elements.Element (Positive (Index));
- end Get;
-
- ------------
- -- Length --
- ------------
-
- function Length (List : Primitive) return Natural is
- begin
- Check_Kind (Kind_List, List);
- return Natural (Elements (List).Length);
- end Length;
-
- ---------------
- -- To_String --
- ---------------
-
- function To_String (Val : Primitive) return String is
- begin
- return Image (To_Text (To_Unbounded_Text (Val)));
- end To_String;
-
- -----------------------
- -- To_Unbounded_Text --
- -----------------------
-
- function To_Unbounded_Text (Val : Primitive) return Unbounded_Text_Type is
- function Node_Image (N : LK.Lk_Node) return Text_Type
- is
- (if N.Is_Null
- then "null"
- else To_Text (N.Image));
-
- package D renames Ada.Directories;
-
- Pool : Primitive_Pool := Create;
- begin
- return T : Unbounded_Text_Type do
- T := (case Kind (Val) is
- when Kind_Unit =>
- To_Unbounded_Text (To_Text ("()")),
- when Kind_Int =>
- Int_Image (Int_Val (Val)),
- when Kind_Str =>
- -- TODO ??? We use Langkit_Support.Text.Image to quote the
- -- string and potentially escape chars in it, but we have
- -- to convert it back & forth from string. We should add
- -- an overload in langkit that returns a Text_Type.
- To_Unbounded_Text
- (To_Text (Image (Str_Val (Val),
- With_Quotes => True))),
- when Kind_Regex => To_Unbounded_Text (""),
- when Kind_Bool =>
- Bool_Image (Bool_Val (Val)),
- when Kind_Node =>
- To_Unbounded_Text (Node_Image (Val.Node_Val)),
- when Kind_Analysis_Unit =>
- To_Unbounded_Text
- (""),
- when Kind_Token =>
- To_Unbounded_Text (To_Text (Val.Token_Val.Image)),
- when Kind_Iterator =>
- Iterator_Image (Val),
- when Kind_List =>
- List_Image (Val.List_Val.all),
- when Kind_Tuple =>
- List_Image (Val.List_Val.all, "(", ")"),
- when Kind_Object =>
- Object_Image (Val.Obj_Assocs.all),
- when Kind_Selector_List =>
- Selector_List_Image (Selector_List_Val (Val)),
- when Kind_Function =>
- "function "
- & To_Unbounded_Text (To_Text (Val.Fun_Node.Image)),
- when Kind_Selector =>
- "selector "
- & To_Unbounded_Text (To_Text (Val.Sel_Node.Image)),
- when Kind_Builtin_Function =>
- To_Unbounded_Text ("builtin function"),
- when Kind_Property_Reference =>
- To_Unbounded_Text
- (""),
- -- TODO: Use Struct_Member_Ref.Name when it is implemented
- when Kind_Namespace =>
- To_Unbounded_Text
- (To_Text (Env_Image
- (Eval_Contexts.Environment_Access (Val.Namespace)))));
- Destroy (Pool);
- end return;
- end To_Unbounded_Text;
-
- ---------------
- -- To_String --
- ---------------
-
- function To_String (Val : Valid_Primitive_Kind) return String is
- begin
- return (case Val is
- when Kind_Unit => "Unit",
- when Kind_Int => "Int",
- when Kind_Str => "Str",
- when Kind_Regex => "Regex",
- when Kind_Bool => "Bool",
- when Kind_Node => "Node",
- when Kind_Token => "Token",
- when Kind_Analysis_Unit => "Analysis_Unit",
- when Kind_Iterator => "Iterator",
- when Kind_List => "List",
- when Kind_Object => "Object",
- when Kind_Tuple => "Tuple",
- when Kind_Selector_List => "Selector List",
- when Kind_Function => "Function",
- when Kind_Builtin_Function => "Builtin Function",
- when Kind_Selector => "Selector",
- when Kind_Namespace => "Namespace",
- when Kind_Property_Reference => "Property_Reference");
- end To_String;
-
- ---------------
- -- Kind_Name --
- ---------------
-
- function Kind_Name (Value : Primitive) return String is
- begin
- return (case Value.Kind is
- when Kind_Node =>
- (if Value.Node_Val.Is_Null
- then "No_Kind"
- else
- (LKI.Debug_Name (LKI.Type_Of (Value.Node_Val)))),
- when others =>
- To_String (Kind (Value)));
- end Kind_Name;
-
- -------------
- -- Display --
- -------------
-
- procedure Display
- (Value : Primitive;
- New_Line : Boolean)
- is
- begin
- case Value.Kind is
- when Kind_Str =>
- Ada.Wide_Wide_Text_IO.Put
- (Str_Val (Value));
- if New_Line then
- Ada.Wide_Wide_Text_IO.New_Line;
- end if;
- when others =>
- declare
- Content : constant Unbounded_Text_Type :=
- To_Unbounded_Text (Value);
- begin
- if New_Line then
- Put_Line (Content);
- else
- Put (Content);
- end if;
- end;
- end case;
- end Display;
-
- ------------
- -- Equals --
- ------------
-
- function Equals (Left, Right : Primitive) return Primitive is
- (To_Primitive (Deep_Equals (Left, Right)));
-
- function Equals (Left, Right : Primitive) return Boolean is
- begin
- if Left = null then
- return Right = null;
- end if;
-
- return Left.Kind = Right.Kind and then Deep_Equals (Left, Right);
- end Equals;
-
- -----------------
- -- Deep_Equals --
- -----------------
-
- function Deep_Equals
- (Left, Right : Primitive) return Boolean
- is
- begin
- if Kind (Left) /= Kind (Right) then
- return False;
- end if;
-
- case Kind (Left) is
- when Kind_List | Kind_Tuple =>
- return Deep_Equals (List_Val (Left), List_Val (Right));
- when Kind_Node =>
- return LK."=" (Left.Node_Val, Right.Node_Val);
- when Kind_Str =>
- return Left.Str_Val.all = Right.Str_Val.all;
- when others =>
- -- HACK: To discard the pool parameter and not have to rewrite the
- -- structural equality for the rest of the components, we create a
- -- fake primitive data where the pool is equal to the pool of the
- -- right item.
- declare
- Fake_Left : Primitive_Data := Left.all;
- begin
- Fake_Left.Pool := Right.Pool;
- return Fake_Left = Right.all;
- end;
- end case;
- end Deep_Equals;
-
- -----------------
- -- Deep_Equals --
- -----------------
-
- function Deep_Equals
- (Left, Right : Primitive_List_Access) return Boolean
- is
- begin
- if Left.Elements.Length /= Right.Elements.Length then
- return False;
- end if;
-
- for I in Left.Elements.First_Index .. Left.Elements.Last_Index loop
- if not Bool_Val (Equals (Left.Elements (I), Right.Elements (I))) then
- return False;
- end if;
- end loop;
-
- return True;
- end Deep_Equals;
-
- ---------
- -- "&" --
- ---------
-
- function Concat
- (Left, Right : Primitive;
- Pool : Primitive_Pool) return Primitive
- is
- begin
- case Kind (Left) is
- when Kind_Str =>
- Check_Kind (Kind_Str, Right);
- return To_Primitive (Str_Val (Left) & Str_Val (Right), Pool);
- when Kind_List =>
- Check_Kind (Kind_List, Right);
- declare
- Ret : constant Primitive := Make_Empty_List (Pool);
- begin
- for El of Left.List_Val.Elements loop
- Ret.List_Val.Elements.Append (El);
- end loop;
- for El of Right.List_Val.Elements loop
- Ret.List_Val.Elements.Append (El);
- end loop;
- return Ret;
- end;
- when others =>
- raise Unsupported_Error with "Wrong kind " & Kind_Name (Right);
- end case;
- end Concat;
-
- ---------
- -- "<" --
- ---------
-
- function Lt
- (Left, Right : Primitive) return Primitive
- is
- begin
- if Kind (Left) /= Kind (Right) then
- Raise_Unsupported_Operation (Left, Right, "<");
- end if;
-
- case Kind (Left) is
- when Kind_Int =>
- return To_Primitive (Int_Val (Left) < Int_Val (Right));
- when Kind_Str =>
- return To_Primitive (Str_Val (Left) < Str_Val (Right));
- when others =>
- Raise_Unsupported_Operation (Left, Right, "<");
- end case;
- end Lt;
-
- ----------
- -- "<=" --
- ----------
-
- function Lte
- (Left, Right : Primitive) return Primitive
- is
- Is_Lt : constant Primitive := Lt (Left, Right);
- begin
- if Bool_Val (Is_Lt) then
- return Is_Lt;
- else
- return Equals (Left, Right);
- end if;
- end Lte;
-
- ---------
- -- ">" --
- ---------
-
- function Gt
- (Left, Right : Primitive) return Primitive
- is
- (To_Primitive
- (not (Bool_Val (Lt (Left, Right))
- or else Bool_Val (Equals (Left, Right)))));
-
- ----------
- -- ">=" --
- ----------
-
- function Gte
- (Left, Right : Primitive) return Primitive
- is
- (To_Primitive (not Bool_Val (Lt (Left, Right))));
-
- -------------------
- -- Extract_Value --
- -------------------
-
- function Extract_Value
- (Obj : Primitive;
- Key : Text_Type;
- Ctx : LKQL.Eval_Contexts.Eval_Context;
- Expected_Kind : Base_Primitive_Kind := No_Kind;
- Location : L.Lkql_Node := L.No_Lkql_Node) return Primitive
- is
- Sym : constant Symbol_Type := Ctx.Symbol (Key);
- Cur : constant Primitive_Maps.Cursor
- := Obj.Obj_Assocs.Elements.Find (Sym);
- begin
- if not Primitive_Maps.Has_Element (Cur) then
- Raise_And_Record_Error
- (Ctx,
- Make_Eval_Error
- (Location, "No key named " & Key & " in object"));
- else
- if Expected_Kind /= No_Kind then
- LKQL.Evaluation.Check_Kind
- (Ctx, Location, Expected_Kind,
- Primitive_Maps.Element (Cur));
- end if;
- return Primitive_Maps.Element (Cur);
- end if;
- end Extract_Value;
-
- function Create return Primitive_Pool_Stack is
- Ret : Primitive_Pool_Stack;
- begin
- Ret := new Primitive_Pool_Vectors.Vector;
- Ret.Append (Create);
- return Ret;
- end Create;
-
- ------------
- -- Create --
- ------------
-
- function Create return Primitive_Pool is
- Ret : constant Primitive_Pool := new Primitive_Pool_Data;
- begin
- return Ret;
- end Create;
-
- ----------
- -- Mark --
- ----------
-
- procedure Mark (Pool_Stack : Primitive_Pool_Stack) is
- begin
- Pool_Stack.Append (Create);
- end Mark;
-
- -------------
- -- Release --
- -------------
-
- procedure Release (Pool_Stack : Primitive_Pool_Stack) is
- Last_Pool : Primitive_Pool := Pool_Stack.Last_Element;
- begin
- Destroy (Last_Pool);
- Pool_Stack.Delete_Last;
- end Release;
-
- -------------
- -- Destroy --
- -------------
-
- procedure Destroy (Pool : in out Primitive_Pool) is
- procedure Free is new Ada.Unchecked_Deallocation
- (Primitive_Pool_Data, Primitive_Pool);
- procedure Free is new Ada.Unchecked_Deallocation
- (Primitive_Data, Primitive);
- begin
- for Prim of Pool.Primitives loop
- Release (Prim.all);
- Free (Prim);
- end loop;
- Free (Pool);
- end Destroy;
-
- -------------
- -- Destroy --
- -------------
-
- procedure Destroy (Self : in out Primitive_Pool_Stack) is
- procedure Free is new Ada.Unchecked_Deallocation
- (Primitive_Pool_Vectors.Vector, Primitive_Pool_Stack);
- begin
- while Self.Length > 0 loop
- Release (Self);
- end loop;
-
- Free (Self);
- end Destroy;
-
- Root_Pool : Primitive_Pool := Create;
-
- ----------------------
- -- Create_Primitive --
- ----------------------
-
- function Create_Primitive
- (Data : Primitive_Data) return Primitive
- is
- Ret : constant Primitive := new Primitive_Data'(Data);
- begin
- Data.Pool.Primitives.Append (Ret);
- return Ret;
- end Create_Primitive;
-
- type Root_Pool_Control is new Ada.Finalization.Controlled with record
- Freed : Boolean := False;
- end record;
-
- overriding procedure Finalize (Self : in out Root_Pool_Control);
-
- --------------
- -- Finalize --
- --------------
-
- overriding procedure Finalize (Self : in out Root_Pool_Control) is
- begin
- if not Self.Freed then
- Destroy (Root_Pool);
- Self.Freed := True;
- end if;
- end Finalize;
-
- Root_Pool_Control_Singleton : constant Root_Pool_Control :=
- (Ada.Finalization.Controlled with Freed => False);
- pragma Unreferenced (Root_Pool_Control_Singleton);
-
- False_Prim : constant Primitive :=
- Create_Primitive
- ((Kind => Kind_Bool, Bool_Val => False, Pool => Root_Pool));
-
- True_Prim : constant Primitive :=
- Create_Primitive
- ((Kind => Kind_Bool, Bool_Val => True, Pool => Root_Pool));
-
- Unit_Prim : constant Primitive :=
- Create_Primitive ((Kind => Kind_Unit, Pool => Root_Pool));
-
- ------------------
- -- To_Primitive --
- ------------------
-
- function To_Primitive (Val : Boolean) return Primitive is
- begin
- return (case Val is
- when True => True_Prim,
- when False => False_Prim);
- end To_Primitive;
-
- -------------------------
- -- Make_Unit_Primitive --
- -------------------------
-
- function Make_Unit_Primitive return Primitive
- is
- begin
- return Unit_Prim;
- end Make_Unit_Primitive;
-
- ----------
- -- Hash --
- ----------
-
- function Hash (Self : Primitive) return Hash_Type is
- begin
- case Self.Kind is
- when Kind_Unit =>
- return Hash_Type (0);
- when Kind_Int =>
- return Ada.Strings.Hash (Image (Self.Int_Val));
- when Kind_Str =>
- return Hash (Self.Str_Val.all);
- when Kind_Regex =>
- raise Constraint_Error with "Hash not supported on regex";
- when Kind_Bool =>
- return Hash_Type (Boolean'Pos (Self.Bool_Val));
- when Kind_Node =>
- return LK.Hash (Self.Node_Val);
- when Kind_Analysis_Unit =>
- return LK.Hash (Self.Analysis_Unit_Val);
- when Kind_Iterator =>
- raise Constraint_Error with "Hash not supported on iterators";
- when Kind_Token =>
- raise Constraint_Error with "Hash not yet supported on tokens";
- when Kind_List | Kind_Tuple =>
- declare
- L : Primitive_Vectors.Vector renames Self.List_Val.Elements;
- Hashes : Hash_Array (L.First_Index .. L.Last_Index);
- begin
- for I in L.First_Index .. L.Last_Index loop
- Hashes (I) := Hash (L (I));
- end loop;
- return Combine (Hashes);
- end;
- when Kind_Object =>
- declare
- L : Primitive_Maps.Map renames Self.Obj_Assocs.Elements;
- Hashes : Hash_Array (1 .. Integer (L.Length));
- I : Integer := 1;
- begin
- for It in L.Iterate loop
- Hashes (I) := Hash (Primitive_Maps.Element (It));
- I := I + 1;
- end loop;
- return Combine (Hashes);
- end;
- when Kind_Selector_List =>
- raise Constraint_Error with "Selector list not hashable";
- when Kind_Builtin_Function =>
- raise Constraint_Error with "Builtin function not hashable";
- when Kind_Property_Reference =>
- raise Constraint_Error with "Property reference not hashable";
- when Kind_Namespace =>
- raise Constraint_Error with "Namespace not hashable";
- when Kind_Function | Kind_Selector =>
- raise Constraint_Error with "Callables not hashable";
- end case;
- end Hash;
-
- ----------
- -- Hash --
- ----------
-
- function Hash (Vec : Primitive_Vectors.Vector) return Hash_Type is
- Hashes : Hash_Array (Vec.First_Index .. Vec.Last_Index);
- begin
- for I in Vec.First_Index .. Vec.Last_Index loop
- Hashes (I) := Hash (Vec (I));
- end loop;
- return Combine (Hashes);
- end Hash;
-
- ----------
- -- Copy --
- ----------
-
- function Copy (Self : Primitive; Pool : Primitive_Pool) return Primitive is
- begin
- case Self.Kind is
- when Kind_Unit | Kind_Bool =>
- -- Unit, True & False are singleton allocated in a global pool.
- -- Don't copy them.
- return Self;
- when Kind_Int =>
- return Create_Primitive
- ((Kind => Kind_Int, Int_Val => Self.Int_Val, Pool => Pool));
- when Kind_Str =>
- return Create_Primitive
- ((Kind => Kind_Str,
- Str_Val => new Text_Type'(Self.Str_Val.all), Pool => Pool));
- when Kind_Node =>
- return Create_Primitive
- ((Kind => Kind_Node, Node_Val => Self.Node_Val, Pool => Pool));
- when Kind_Analysis_Unit =>
- return Create_Primitive
- ((Kind => Kind_Analysis_Unit,
- Analysis_Unit_Val => Self.Analysis_Unit_Val, Pool => Pool));
- when Kind_Iterator =>
- raise Constraint_Error with "Copy not supported on iterators";
- when Kind_Regex =>
- raise Constraint_Error with "Copy not supported on regex";
- when Kind_Token =>
- return Create_Primitive
- ((Kind => Kind_Token, Token_Val => Self.Token_Val,
- Pool => Pool));
- when Kind_List | Kind_Tuple =>
- declare
- L : Primitive_Vectors.Vector renames Self.List_Val.Elements;
- New_List : Primitive_Vectors.Vector;
- New_Primitive_Val : Primitive_Data := Self.all;
- begin
- New_List.Set_Length (Count_Type (L.Last_Index));
- for I in L.First_Index .. L.Last_Index loop
- New_List (I) := Copy (L (I), Pool);
- end loop;
- New_Primitive_Val.Pool := Pool;
- New_Primitive_Val.List_Val :=
- new Primitive_List'(Elements => New_List);
- return Create_Primitive (New_Primitive_Val);
- end;
- when Kind_Object =>
- declare
- L : Primitive_Maps.Map renames Self.Obj_Assocs.Elements;
- New_Map : Primitive_Maps.Map;
- begin
- for It in L.Iterate loop
- New_Map.Include
- (Primitive_Maps.Key (It),
- Copy (Primitive_Maps.Element (It), Pool));
- end loop;
- return Create_Primitive
- ((Kind => Kind_Object,
- Obj_Assocs => new Primitive_Assocs'(Elements => New_Map),
- Pool => Pool));
- end;
- when Kind_Selector_List =>
- raise Constraint_Error with "Selector list not copyable";
- when Kind_Builtin_Function =>
- raise Constraint_Error with "Builtin function not copyable";
- when Kind_Property_Reference =>
- raise Constraint_Error with "Property reference not copyable";
- when Kind_Namespace =>
- raise Constraint_Error with "Namespace not copyable";
- when Kind_Function | Kind_Selector =>
- raise Constraint_Error with "Callables not copyable";
- end case;
- end Copy;
-
- package body Callable_Caches is
-
- ------------
- -- Create --
- ------------
-
- function Create (Pool : Primitive_Pool) return Cache is
- begin
- return new Cache_Data'(Pool => Pool, Cache => <>);
- end Create;
-
- -----------
- -- Query --
- -----------
-
- function Query
- (Self : Cache; Args : Primitive_Vectors.Vector) return Primitive
- is
- C : constant Cache_Maps.Cursor := Self.Cache.Find (Args);
- begin
- if Cache_Maps.Has_Element (C) then
- return Cache_Maps.Element (C);
- end if;
- return null;
- end Query;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Self : Cache; Args : Primitive_Vectors.Vector; Value : Primitive)
- is
- Copied_Args : Primitive_Vectors.Vector;
- begin
- for A of Args loop
- Copied_Args.Append (Copy (A, Self.Pool));
- end loop;
- Self.Cache.Include (Copied_Args, Copy (Value, Self.Pool));
- end Insert;
-
- end Callable_Caches;
-
-end LKQL.Primitives;
diff --git a/lkql/extensions/src/lkql-primitives.ads b/lkql/extensions/src/lkql-primitives.ads
deleted file mode 100644
index 5e6a6b7c5..000000000
--- a/lkql/extensions/src/lkql-primitives.ads
+++ /dev/null
@@ -1,727 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Hashed_Maps;
-with Ada.Containers.Vectors;
-with Ada.Containers; use Ada.Containers;
-with Ada.Unchecked_Deallocation;
-
-with GNAT.Regpat;
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-with Options;
-with Iters.Iterators;
-with Iters.Vec_Iterators;
-with LKQL.Selector_Lists; use LKQL.Selector_Lists;
-with LKQL.Adaptive_Integers; use LKQL.Adaptive_Integers;
-
-limited with LKQL.Eval_Contexts;
-
-package LKQL.Primitives is
-
- Unsupported_Error : exception;
-
- type Primitive_List;
- -- List of Primitive Values
-
- type Primitive_List_Access is access Primitive_List;
- -- Pointer to a list of Primitive values
-
- type Primitive_Assocs;
-
- type Primitive_Assocs_Access is access Primitive_Assocs;
-
- type Iterator_Primitive;
-
- type Iterator_Primitive_Access is access all Iterator_Primitive;
-
- type Base_Primitive_Kind is
- (Kind_Unit,
- -- Unit value: representation of the result of a computation that
- -- doesn't produce a meaningful result.
-
- Kind_Int,
- -- Integer value, encoded as an Ada Integer or Big Integer
-
- Kind_Str,
- -- Unicode String value
-
- Kind_Bool,
- -- Either 'true' or 'false'
-
- Kind_Node,
- -- Libadalang node
-
- Kind_Iterator,
- -- Iterator yielding Primitive values
-
- Kind_List,
- -- List of Primitive values
-
- Kind_Object,
- -- object
-
- Kind_Tuple,
- -- Tuple of primitive values
-
- Kind_Selector_List,
- -- Lazy 'list' returned by a selector
-
- Kind_Function,
- -- Functions objects
-
- Kind_Builtin_Function,
- -- Builtin function objects
-
- Kind_Namespace,
- -- Namespace objects
-
- Kind_Property_Reference,
- -- Reference to a Langkit property
-
- Kind_Token,
- -- Langkit token
-
- Kind_Regex,
- -- Regex pattern
-
- Kind_Analysis_Unit,
- -- Langkit analysis unit
-
- Kind_Selector,
- -- Selector objects
-
- No_Kind
- -- Special value that allows using this enum as an option type
- );
- -- Denotes the kind of a primitive value
-
- subtype Valid_Primitive_Kind is Base_Primitive_Kind
- range Kind_Unit .. Kind_Selector;
-
- subtype Sequence_Kind is Valid_Primitive_Kind
- range Kind_Iterator .. Kind_List;
-
- subtype Introspectable_Kind is Valid_Primitive_Kind
- with Static_Predicate =>
- Introspectable_Kind not in
- Kind_Tuple | Kind_Unit | Kind_Function
- | Kind_Selector | Kind_Builtin_Function | Kind_Namespace
- | Kind_Property_Reference | Kind_Object;
-
- type Environment_Access is access all LKQL.Eval_Contexts.Environment;
-
- type Builtin_Function_Description (<>);
- -- Forward definition of the Builtin_Function_Description type.
-
- type Builtin_Function is access all Builtin_Function_Description;
- -- This is a painful indirection due to the fact that we cannot declare an
- -- access to function returning a primitive before the primitive type is
- -- defined, but that we need to store it in Primitive_Data. This incurs
- -- a performance penalty since we have to dynamically allocate those, but
- -- since builtin functions will be allocated only once this is better than
- -- storing an address and coercing, because it will allow a friendlier API.
-
- type Primitive_Data;
-
- ---------------
- -- Primitive --
- ---------------
-
- type Primitive is access all Primitive_Data;
-
- function Deep_Equals
- (Left, Right : Primitive) return Boolean;
- -- Perform a deep equality check between 'Left' and 'Right'.
- -- An Unsupported exception will be raised if Left and Right have different
- -- kinds.
-
- function Equals (Left, Right : Primitive) return Boolean;
-
- package Primitive_Vectors is new
- Ada.Containers.Vectors (Index_Type => Positive,
- Element_Type => Primitive,
- "=" => Equals);
- -- Vector of Primitive values
-
- type Primitive_Vector_Access is access all Primitive_Vectors.Vector;
- -- Pointer to a vector of Primitive values
-
- type Primitive_List is record
- Elements : aliased Primitive_Vectors.Vector;
- end record;
- -- List of primitive values.
-
- type Primitive_Array is array (Positive range <>) of Primitive;
-
- function Hash (Vec : Primitive_Vectors.Vector) return Hash_Type;
-
- procedure Free_Primitive_List is
- new Ada.Unchecked_Deallocation (Primitive_List, Primitive_List_Access);
-
- procedure Free_Primitive_Vector is new Ada.Unchecked_Deallocation
- (Primitive_Vectors.Vector, Primitive_Vector_Access);
-
- package Positive_Vectors
- is new Ada.Containers.Vectors (Positive, Positive);
-
- type Primitive_Pool_Data is record
- Primitives : Primitive_Vectors.Vector;
- -- List of primitives allocated in this pool
- end record;
-
- type Primitive_Pool is access all Primitive_Pool_Data;
- -- Pool of primitives: In LKQL, primitives are not managed by hand, but are
- -- instead allocated in a pool. The pool can then be freed all at once, or
- -- released from time to time.
- --
- -- This allows us to create pool for "analysis frames", and free them,
- -- which is a kind of poor man's garbage collection, but works well enough
- -- for our purpose.
-
- package Primitive_Pool_Vectors
- is new Ada.Containers.Vectors (Positive, Primitive_Pool);
-
- type Primitive_Pool_Stack is access all Primitive_Pool_Vectors.Vector;
-
- function Create return Primitive_Pool_Stack;
-
- procedure Destroy (Self : in out Primitive_Pool_Stack);
-
- procedure Mark (Pool_Stack : Primitive_Pool_Stack);
- -- Add a new mark in the pool. The next call to release will call every
- -- object allocated *after* mark has been called.
-
- procedure Release (Pool_Stack : Primitive_Pool_Stack);
- -- Remove all the objects from the pool up until the last mark.
-
- function Create_Primitive
- (Data : Primitive_Data) return Primitive;
-
- package Callable_Caches is
- type Cache is private;
-
- function Create (Pool : Primitive_Pool) return Cache;
-
- function Query
- (Self : Cache; Args : Primitive_Vectors.Vector) return Primitive;
-
- procedure Insert
- (Self : Cache; Args : Primitive_Vectors.Vector; Value : Primitive);
-
- No_Cache : constant Cache;
-
- private
-
- package Cache_Maps is new Ada.Containers.Hashed_Maps
- (Primitive_Vectors.Vector,
- Primitive,
- Hash => Hash,
- Equivalent_Keys => Primitive_Vectors."=");
-
- type Cache_Data is record
- Pool : Primitive_Pool;
- Cache : Cache_Maps.Map;
- end record;
-
- type Cache is access all Cache_Data;
-
- No_Cache : constant Cache := null;
-
- end Callable_Caches;
-
- type Cached_Sel_Node is record
- Node : LK.Lk_Node;
- Mode : L.Selector_Expr_Mode;
- end record;
-
- pragma Warnings (Off, "padded");
- package Nodes_Vectors
- is new Ada.Containers.Vectors (Positive, Cached_Sel_Node);
- pragma Warnings (On, "padded");
-
- type Node_Vector is access all Nodes_Vectors.Vector;
-
- package Node_To_Nodes is new Ada.Containers.Hashed_Maps
- (LK.Lk_Node,
- Node_Vector,
- Hash => LK.Hash,
- Equivalent_Keys => LK."=");
-
- type Sel_Cache_Type is access all Node_To_Nodes.Map;
-
- type Text_Type_Access is access all Text_Type;
- procedure Free
- is new Ada.Unchecked_Deallocation (Text_Type, Text_Type_Access);
-
- type Regex_Access is access all GNAT.Regpat.Pattern_Matcher;
-
- type Primitive_Data (Kind : Valid_Primitive_Kind) is record
- Pool : Primitive_Pool;
- case Kind is
- when Kind_Unit =>
- null;
- when Kind_Int =>
- Int_Val : Adaptive_Integer;
- when Kind_Str =>
- Str_Val : Text_Type_Access;
- when Kind_Regex =>
- Regex_Val : Regex_Access;
- when Kind_Bool =>
- Bool_Val : Boolean;
- when Kind_Node =>
- Node_Val : LK.Lk_Node;
- when Kind_Token =>
- Token_Val : LK.Lk_Token;
- when Kind_Analysis_Unit =>
- Analysis_Unit_Val : LK.Lk_Unit;
- when Kind_Iterator =>
- Iter_Val : Iterator_Primitive_Access;
- Iter_Cache : Primitive_List_Access;
- when Kind_List | Kind_Tuple =>
- List_Val : Primitive_List_Access;
- when Kind_Object =>
- Obj_Assocs : Primitive_Assocs_Access;
- when Kind_Selector_List =>
- Selector_List_Val : Selector_List;
- when Kind_Builtin_Function =>
- Builtin_Fn : Builtin_Function;
- when Kind_Property_Reference =>
- Ref : LKI.Struct_Member_Ref;
- Property_Node : LK.Lk_Node;
- when Kind_Namespace =>
- Namespace : Environment_Access;
- Module : L.Lkql_Node;
- when Kind_Function | Kind_Selector =>
- Frame : Environment_Access;
- case Kind is
- when Kind_Function =>
- Fun_Node : L.Base_Function;
- Call_Cache : Callable_Caches.Cache;
- when Kind_Selector =>
- Sel_Node : L.Selector_Decl;
- Sel_Cache : Sel_Cache_Type;
- when others => null;
- end case;
- end case;
- end record;
- -- Store a primitive value, which can be an atomic type (Bool, Int, ...),
- -- an AST node, or a list of Primitive values.
-
- procedure Release (Data : in out Primitive_Data);
- -- Release if data is of Kind Kind_List, free the list's memory
-
- function Hash (Self : Primitive) return Hash_Type;
- -- Hash function for LKQL's primitive type
-
- function Copy (Self : Primitive; Pool : Primitive_Pool) return Primitive;
- -- Deep copy of a primitive value
-
- subtype Introspectable_Primitive is Primitive
- with Predicate =>
- Introspectable_Primitive.Kind
- in Introspectable_Kind
- or else raise Constraint_Error
- with "Wrong kind for Introspectable_Primitive: "
- & Introspectable_Primitive.Kind'Image;
-
- package Primitive_Options is new Options (Primitive);
- -- Optional Primitive values
-
- subtype Primitive_Option is Primitive_Options.Option;
- -- Optional primitive value
-
- type Native_Function_Access is access function
- (Ctx : LKQL.Eval_Contexts.Eval_Context;
- Args : Primitive_Array) return Primitive;
-
- type Builtin_Param_Description is record
- Name : Unbounded_Text_Type;
- Expected_Kind : Base_Primitive_Kind := No_Kind;
- Default_Value : Primitive_Option := Primitive_Options.None;
- end record;
-
- type Builtin_Function_Profile is
- array (Positive range <>) of Builtin_Param_Description;
-
- Empty_Profile : constant Builtin_Function_Profile (1 .. 0) :=
- (others => <>);
-
- type Builtin_Function_Description (N : Natural) is record
- Name : Unbounded_Text_Type;
- -- Name of the built-in function
-
- Params : Builtin_Function_Profile (1 .. N);
- -- Parameters descriptions
-
- Fn_Access : Native_Function_Access;
- -- Access to the native function to call for this function
-
- Doc : Unbounded_Text_Type;
- -- Documentation for the builtin
-
- Only_Dot_Calls : Boolean;
- -- Whether this builtin can be called via the regular call syntax, or
- -- only via dot calls on entities with the same kind as the function's
- -- first argument.
- end record;
-
- -----------------------
- -- Primitive_Assocs --
- -----------------------
-
- package Primitive_Maps is new
- Ada.Containers.Hashed_Maps
- (Key_Type => Symbol_Type,
- Element_Type => Primitive,
- Hash => Hash,
- Equivalent_Keys => "=");
-
- type Primitive_Assocs is record
- Elements : Primitive_Maps.Map;
- end record;
-
- procedure Free_Primitive_Assocs is new Ada.Unchecked_Deallocation
- (Primitive_Assocs, Primitive_Assocs_Access);
-
- --------------
- -- Iterator --
- --------------
-
- package Primitive_Iters is new Iters.Iterators (Primitive);
- -- Iterator over Primitive values
-
- package Primitive_Vec_Iters is
- new Iters.Vec_Iterators (Primitive_Vectors, Primitive_Iters);
- -- Iterators over Primitive vectors
-
- subtype Primitive_Iter is Primitive_Iters.Iterator_Interface;
-
- subtype Primitive_Iter_Access is Primitive_Iters.Iterator_Access;
- -- Pointer to an iterator over Primitive values
-
- type Iterator_Primitive is record
- Iter : Primitive_Iter_Access;
- end record;
- -- Lazy stream of Primitive_values
-
- function Get_Iter (Value : Iterator_Primitive) return Primitive_Iter_Access;
- -- Return a deep copy of the wrapped iterator
-
- procedure Consume (Iter : Primitive; Num_Elements : Integer := -1)
- with Pre => Iter.Kind = Kind_Iterator;
-
- function To_Iterator
- (Value : Primitive; Pool : Primitive_Pool) return Primitive_Iter'Class;
- -- Create an iterator that yields the elements of a List or
- -- Iterator Primitive.
- -- Raise an Unsupported_Error if the value isn't a List or an Iterator
-
- procedure Free_Iterator_Primitive is
- new Ada.Unchecked_Deallocation
- (Iterator_Primitive, Iterator_Primitive_Access);
-
- -------------------
- -- Selector list --
- -------------------
-
- function To_List
- (Value : Selector_List; Pool : Primitive_Pool) return Primitive;
- -- Create a List Primitive value from a Selector_List Primitive value
-
- ---------------
- -- Accessors --
- ---------------
-
- function Kind (Value : Primitive) return Valid_Primitive_Kind;
- -- Return the kind of a primitive
-
- function Int_Val (Value : Primitive) return Adaptive_Integer;
- -- Return the value of an Int primitive
-
- function Str_Val (Value : Primitive) return Text_Type;
- -- Return the value of a Str primitive
-
- function Bool_Val (Value : Primitive) return Boolean;
- -- Return the value of a Bool primitive
-
- function Node_Val (Value : Primitive) return LK.Lk_Node;
- -- Return the value of a Node primitive
-
- function List_Val (Value : Primitive) return Primitive_List_Access;
- -- Return the value of a list primitive
-
- function Selector_List_Val (Value : Primitive) return Selector_List;
- -- Return the value of a selector list primitive
-
- function Iter_Val (Value : Primitive) return Iterator_Primitive_Access;
- -- Return the value of an iterator primitive
-
- function Elements
- (Value : Primitive) return not null Primitive_Vector_Access;
- -- Return a pointer to the elements of a list or iterable primitive. If the
- -- primitive is an iterator, consume it beforehand.
-
- function Data
- (Value : Primitive;
- Member_Name : Text_Type;
- Pool : Primitive_Pool) return Primitive;
- -- Return the value of 'Value's member named 'Member_Name'.
- -- This member can be either a built_in member (ex: length), or a
- -- Langkit field/property.
- -- Raise an Unsupported_Error if there is no member named
- -- 'Member_Name'.
-
- function Is_Nullish (Value : Primitive) return Boolean;
- -- Return whether the value is null or unit.
-
- function Booleanize (Value : Primitive) return Boolean;
- -- Turn the value into an Ada boolean value, according to the logic:
- --
- -- * ``false``, the unit value and the null node are False
- -- * Everything else is True
-
- function Truthy (Value : Primitive; Has_Truthy : out Boolean)
- return Boolean;
- -- Given a primitive, returns true iif it can be evaluated as being
- -- "true", ie it is a Boolean with the value True, a non-null node, a
- -- a non-empty list, or a non-empty iterable.
- -- Returns false for unit primitives that represent absence of result
- -- for eg. has_aspect calls.
- -- If the primitive doesn't have a truthy value, Has_Truthy is set to False
- -- and the function result is False.
-
- ----------------------------------
- -- Creation of Primitive values --
- ----------------------------------
-
- function Make_Unit_Primitive return Primitive;
- -- Create a Unit Primitive value
-
- function To_Primitive
- (Val : Integer; Pool : Primitive_Pool) return Primitive;
- -- Create a Primitive value from the Integer value
-
- function To_Primitive
- (Val : Adaptive_Integer; Pool : Primitive_Pool) return Primitive;
- -- Create a Primitive value from the Adaptive_Integer value
-
- function To_Primitive
- (Val : Text_Type; Pool : Primitive_Pool) return Primitive;
- -- Create a Primitive value from the String value
-
- function To_Primitive (Val : Boolean) return Primitive;
- -- Create a Bool primitive
-
- function To_Primitive
- (Node : LK.Lk_Node; Pool : Primitive_Pool) return Primitive;
- -- Create a Primitive value from the Lkql_Node value
-
- function To_Primitive
- (Token : LK.Lk_Token; Pool : Primitive_Pool) return Primitive;
- -- Create a primitive value from the AST_Token value
-
- function To_Primitive
- (Unit : LK.Lk_Unit; Pool : Primitive_Pool) return Primitive;
- -- Create a primitive value from the AST_Unit value
-
- function To_Primitive
- (Val : Primitive_Iter'Class; Pool : Primitive_Pool) return Primitive;
-
- function To_Primitive
- (Val : Selector_List; Pool : Primitive_Pool) return Primitive;
- -- Create a Primitive value from a Selector_List;
-
- function Make_Empty_List (Pool : Primitive_Pool) return Primitive;
- -- Return a primitive value storing an empty list.
-
- function Make_Empty_Object (Pool : Primitive_Pool) return Primitive;
- -- Return a primitive value storing an empty object.
-
- function Make_Empty_Tuple (Pool : Primitive_Pool) return Primitive;
-
- function Make_Namespace
- (N : Environment_Access;
- Module : L.Lkql_Node;
- Pool : Primitive_Pool) return Primitive;
-
- function Make_Regex
- (Regex : GNAT.Regpat.Pattern_Matcher;
- Pool : Primitive_Pool) return Primitive;
-
- ---------------------
- -- Function values --
- ---------------------
-
- function Make_Builtin_Function
- (Fn : Builtin_Function; Pool : Primitive_Pool) return Primitive;
-
- function Make_Function
- (Node : L.Base_Function;
- Env : Environment_Access;
- Pool : Primitive_Pool;
- With_Call_Cache : Boolean := False) return Primitive;
-
- function Make_Selector
- (Node : L.Selector_Decl;
- Env : Environment_Access;
- Pool : Primitive_Pool;
- With_Call_Cache : Boolean := False) return Primitive;
-
- function Make_Property_Reference
- (Node_Val : LK.Lk_Node;
- Property_Ref : LKI.Struct_Member_Ref;
- Pool : Primitive_Pool) return Primitive;
-
- function Profile (Obj : Primitive) return Text_Type;
- -- For a callable object, return its profile (name + arguments) as text.
-
- --------------------
- -- List Functions --
- --------------------
-
- procedure Append (List, Element : Primitive);
- -- Add `Element` to the end of `List`.
- -- An Unsupported_Error will be raised if `List` is not a value of kind
- -- Kind_List, or if the kind of `Element` doesn't match the kind of the
- -- values stored in `List`.
-
- procedure Extend (List, New_Value : Primitive);
- -- Push 'New_value' to the end of 'List'.
- -- If 'New_value' is a list or iterator, it's elements will be pushed
- -- in order.
- -- An Unsupported_Error will be raise if 'List' is not a value of kind
- -- Kind_List.
-
- function Contains
- (List, Value : Primitive) return Boolean;
- -- Check whether `List` contains `Value`.
- -- An Unsupported_Error will be raised if `List` is not a value of kind
- -- Kind_List, or if the kind of `Value` doesn't match the kind of the
- -- values stored in `List`.
-
- function Get
- (List : Primitive; Index : Integer;
- Raise_If_OOB : Boolean := True) return Primitive;
- -- Return the element of 'List' at 'Index'.
- -- Raise an Unsupported_Error exception if 'Index' is out of bounds.
-
- function Get
- (List : Primitive_List_Access; Index : Integer;
- Raise_If_OOB : Boolean := True) return Primitive;
- -- Return the element of 'List' at 'Index'.
- -- Raise an Unsupported_Error exception if 'Index' is out of bounds.
-
- function Length (List : Primitive) return Natural;
- -- Return the length of the list.
- -- An Unsupported_Error will be raised if List is not a value of kind
- -- Kind_List.
-
- ----------------------
- -- Object functions --
- ----------------------
-
- function Extract_Value
- (Obj : Primitive;
- Key : Text_Type;
- Ctx : LKQL.Eval_Contexts.Eval_Context;
- Expected_Kind : Base_Primitive_Kind := No_Kind;
- Location : L.Lkql_Node := L.No_Lkql_Node) return Primitive;
- -- Extract a value from a primitive object, with the given key, doing the
- -- appropriate checks along the way.
-
- ------------------------------
- -- Text conversion & output --
- ------------------------------
-
- function To_Unbounded_Text (Val : Primitive) return Unbounded_Text_Type;
- -- Return a unicode String representation of `Val`
-
- function To_String (Val : Primitive) return String;
- -- Return a string representation of ``Val``
-
- function To_String (Val : Valid_Primitive_Kind) return String;
- -- Return a String representation of `Val`
-
- function Kind_Name (Value : Primitive) return String;
- -- Return a String representing the kind of `Value`
-
- procedure Display
- (Value : Primitive;
- New_Line : Boolean);
- -- Print a Primitive value onto the console.
-
- ---------------
- -- Operators --
- ---------------
-
- function Equals
- (Left, Right : Primitive) return Primitive;
- -- Perform a deep equality check between 'Left' and 'Right'.
- -- An Unsupported exception will be raised if Left and Right have different
- -- kinds.
-
- function Deep_Equals
- (Left, Right : Primitive_List_Access) return Boolean;
- -- Perform a deep equality check between two primitive_List_Access values.
- -- An Unsupported exception will be raised if Left and Right have different
- -- kinds.
-
- function Concat
- (Left, Right : Primitive;
- Pool : Primitive_Pool) return Primitive;
- -- Concatenate a Primitive value to a Str Primitive.
- -- The supported operations are: Str & Int, Str & Str, Str & Bool.
- -- Unsupported operations will raise an Unsupported_Error exception.
-
- function Lt
- (Left, Right : Primitive) return Primitive;
- -- Tests that 'Left' is strictly lower than 'Right'.
- -- The supported operations are: Int < Int, String < String.
- -- Unsupported operations will raise an Unsupported_Error exception.
-
- function Lte
- (Left, Right : Primitive) return Primitive;
- -- Tests that 'Left' is equal to, or lower than than 'Right'.
- -- The supported operations are: Int <= Int, String <= String.
- -- Unsupported operations will raise an Unsupported_Error exception.
-
- function Gt
- (Left, Right : Primitive) return Primitive;
- -- Tests that 'Left' is strictly higher than 'Right'.
- -- The supported operations are: Int > Int, String > String.
- -- Unsupported operations will raise an Unsupported_Error exception.
-
- function Gte
- (Left, Right : Primitive) return Primitive;
- -- Tests that 'Left' is equal to, or higher than than 'Right'.
- -- The supported operations are: Int >= Int, String >= String.
- -- Unsupported operations will raise an Unsupported_Error exception.
-
- procedure Check_Kind
- (Expected_Kind : Valid_Primitive_Kind; Value : Primitive);
- -- Raise an Unsupporter_Error exception if Value.Kind is different than
- -- Expected_Kind.
-
-end LKQL.Primitives;
diff --git a/lkql/extensions/src/lkql-queries.adb b/lkql/extensions/src/lkql-queries.adb
deleted file mode 100644
index 416f8280a..000000000
--- a/lkql/extensions/src/lkql-queries.adb
+++ /dev/null
@@ -1,303 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with GNAT.Traceback.Symbolic;
-
-with Ada.Text_IO; use Ada.Text_IO;
-
-with Langkit_Support.Errors; use Langkit_Support.Errors;
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-with LKQL.Patterns; use LKQL.Patterns;
-with LKQL.Primitives; use LKQL.Primitives;
-with LKQL.Evaluation; use LKQL.Evaluation;
-with LKQL.Patterns.Match; use LKQL.Patterns.Match;
-with LKQL.Error_Handling; use LKQL.Error_Handling;
-with LKQL.Errors; use LKQL.Errors;
-with LKQL.Depth_Nodes; use LKQL.Depth_Nodes;
-with LKQL.Custom_Selectors; use LKQL.Custom_Selectors;
-
-with Ada.Exceptions; use Ada.Exceptions;
-
-package body LKQL.Queries is
-
- -------------------------
- -- Make_Query_Iterator --
- -------------------------
-
- function Make_Query_Iterator
- (Ctx : Eval_Context;
- Node : L.Query) return Lk_Node_Iterator'Class
- is
- function Build_Iterator
- (Nodes : Lk_Node_Vector) return Lk_Node_Iterator'Class;
-
- function Build_Iterator
- (Nodes : Lk_Node_Vector) return Lk_Node_Iterator'Class
- is
- use all type Langkit_Support.Text.Unbounded_Text_Type;
- begin
- if not Node.F_Through_Expr.Is_Null then
- -- There is a through expression
- if Node.F_Through_Expr.Kind in LCO.Lkql_Identifier_Range
- and then Node.F_Through_Expr.As_Identifier.P_Sym
- = "follow_generics"
- then
- return Make_Child_Iterator
- (Nodes, Follow_Instantiations => True);
- -- Special case for follow_generics (Ada)
- else
-
- -- General case, use a selector
- declare
- -- TODO: Add support for iterating over list via the
- -- selector syntax
- Root : constant Lk_Node := Nodes.Element (1);
-
- Sel : constant Primitive :=
- Eval (Ctx, Node.F_Through_Expr);
- begin
- return To_Lk_Node_Iterator
- (Depth_Node_Iter'Class
- (Make_Custom_Selector_Iter
- (Ctx, Sel, L.No_Expr, L.No_Expr, Root)));
- end;
- end if;
- else
- return Make_Child_Iterator (Nodes);
- end if;
- end Build_Iterator;
-
- function Nodes return Lk_Node_Iterator_Access;
-
- -----------
- -- Nodes --
- -----------
-
- function Nodes return Lk_Node_Iterator_Access is
- Vec : Lk_Node_Vector;
- begin
-
- if Node.F_From_Expr.Is_Null then
-
- for Node of Ctx.AST_Roots.all loop
- Vec.Append (Node);
- end loop;
-
- -- First case, there is no "from" in the query. In that case, the
- -- implicit roots of the query are the roots of the LKQL eval
- -- context.
-
- return new Lk_Node_Iterator'Class'(Build_Iterator (Vec));
- else
-
- -- Second case, there is a "from" clause in the query.
-
- declare
- -- First, eval the expression.
- Eval_From_Expr : constant Primitive :=
- Eval (Ctx, Node.F_From_Expr);
- begin
- case Eval_From_Expr.Kind is
-
- -- If it's a single node, create an array with just this
- -- element.
- when Kind_Node =>
- Vec.Append (Eval_From_Expr.Node_Val);
-
- -- If it's a list, it needs to be a list of nodes. Create a
- -- vector from it to create the iterator from.
- when Kind_List =>
- for El of Eval_From_Expr.List_Val.Elements loop
- if El.Kind /= Kind_Node then
- -- TODO: For the moment it's impossible to exert
- -- this check in queries, because only queries
- -- return lists (comprehensions return iterators
- -- and selectors selector lists). We need to unify
- -- the sequence types somehow, because having a
- -- list comprehension in a "from" appears
- -- potentially useful, and is not possible yet.
- Raise_And_Record_Error
- (Ctx,
- Make_Eval_Error
- (Node.F_From_Expr.As_Lkql_Node,
- "Wrong kind of element in list for "
- & "`from clause`"));
- end if;
- Vec.Append (El.Node_Val);
- end loop;
-
- -- If it's any other kind of node, then it's an error
- when others =>
- Raise_And_Record_Error
- (Ctx,
- Make_Eval_Error
- (Node.F_From_Expr.As_Lkql_Node,
- "Wrong kind of element in `from clause`"));
- end case;
-
- return new Lk_Node_Iterator'Class'(Build_Iterator (Vec));
- end;
- end if;
- end Nodes;
-
- begin
- case Node.F_Pattern.Kind is
- when LCO.Lkql_Chained_Node_Pattern_Range =>
- declare
- Chained : constant Chained_Pattern_Iterator :=
- Make_Chained_Pattern_Iterator
- (Ctx,
- Nodes,
- Node.F_Pattern.P_Value_Part.As_Chained_Node_Pattern);
- begin
- return Chained_Pattern_Query_Iter'
- (Ctx => Ctx.Ref_Frame,
- Iter => Chained);
- end;
- when others =>
- declare
- Predicate : constant Lk_Node_Predicate_Access :=
- Lk_Node_Predicate_Access
- (Make_Query_Predicate (Ctx, Node.F_Pattern));
- begin
- return Lk_Node_Iterators.Filter (Nodes, Predicate);
- end;
- end case;
- end Make_Query_Iterator;
-
- --------------------------
- -- Make_Query_Predicate --
- --------------------------
-
- function Make_Query_Predicate
- (Ctx : Eval_Context; Pattern : L.Base_Pattern)
- return Query_Predicate_Access
- is
- begin
- return new Query_Predicate'(Ctx.Ref_Frame, Pattern);
- end Make_Query_Predicate;
-
- --------------
- -- Evaluate --
- --------------
-
- overriding function Evaluate
- (Self : in out Query_Predicate; Node : Lk_Node) return Boolean
- is
- begin
- declare
- Match : constant Match_Result :=
- Match_Pattern (Self.Ctx,
- Self.Pattern,
- To_Primitive (Node, Self.Ctx.Pool));
- begin
- return Match.Is_Success;
- end;
-
- exception
- when E : Property_Error =>
- case Property_Error_Recovery is
- when Continue_And_Log =>
- Eval_Trace.Trace ("Evaluating query predicate failed");
- Eval_Trace.Trace ("pattern => " & Self.Pattern.Image);
- Eval_Trace.Trace
- ("ada node => " & Node.Image);
-
- Eval_Trace.Trace (Exception_Information (E));
- Eval_Trace.Trace
- (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
-
- when Continue_And_Warn =>
- -- TODO: Use Langkit_Support.Diagnostics.Output
- Put_Line (Standard_Error, "Evaluating query predicate failed");
- Put_Line (Standard_Error, "pattern => " & Self.Pattern.Image);
- Put_Line
- (Standard_Error, "ada node => "
- & Node.Image);
- when Raise_Error =>
- raise;
- end case;
-
- return False;
- end Evaluate;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone
- (Self : Query_Predicate) return Query_Predicate
- is
- begin
- return Query_Predicate'(Self.Ctx, Self.Pattern);
- end Clone;
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Self : in out Query_Predicate) is
- begin
- Self.Ctx.Release_Current_Frame;
- end Release;
-
- ----------
- -- Next --
- ----------
-
- overriding function Next
- (Iter : in out Chained_Pattern_Query_Iter;
- Result : out Lk_Node) return Boolean
- is
- Match : Match_Result;
- begin
- -- The inner iterator is empty: return false
- if not Iter.Iter.Next (Match) then
- return False;
- end if;
-
- Result := Node_Val (Match.Get_Matched_Value);
- return True;
- end Next;
-
- -----------
- -- Clone --
- -----------
-
- overriding function Clone (Iter : Chained_Pattern_Query_Iter)
- return Chained_Pattern_Query_Iter
- is
- (Iter.Ctx.Ref_Frame, Iter.Iter.Clone);
-
- -------------
- -- Release --
- -------------
-
- overriding procedure Release (Iter : in out Chained_Pattern_Query_Iter) is
- begin
- Iter.Ctx.Release_Current_Frame;
- Iter.Iter.Release;
- end Release;
-
-end LKQL.Queries;
diff --git a/lkql/extensions/src/lkql-queries.ads b/lkql/extensions/src/lkql-queries.ads
deleted file mode 100644
index 9638b88fb..000000000
--- a/lkql/extensions/src/lkql-queries.ads
+++ /dev/null
@@ -1,83 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with LKQL.Chained_Pattern; use LKQL.Chained_Pattern;
-with LKQL.Lk_Nodes_Iterators; use LKQL.Lk_Nodes_Iterators;
-
-private package LKQL.Queries is
-
- function Make_Query_Iterator
- (Ctx : Eval_Context;
- Node : L.Query) return Lk_Node_Iterator'Class;
- -- Returns an iterator over the AST nodes, yielding only the elements that
- -- belong to the result of the given query.
-
- ---------------------
- -- Query_Predicate --
- ---------------------
-
- type Query_Predicate is new Lk_Node_Iterator_Predicate with record
- Ctx : Eval_Context;
- Pattern : L.Base_Pattern;
- end record;
- -- Predicate that returns true for every node that belongs to the
- -- result of the given query.
-
- type Query_Predicate_Access is access all Query_Predicate;
- -- Pointer to a Query_predicate
-
- function Make_Query_Predicate
- (Ctx : Eval_Context; Pattern : L.Base_Pattern)
- return Query_Predicate_Access;
- -- Return a pointer to a Query_Predicate that returns true for every node
- -- that belongs to the result set of the given query.
-
- overriding function Evaluate
- (Self : in out Query_Predicate; Node : Lk_Node) return Boolean;
- -- Evaluate the given predicate against 'Node'
-
- overriding function Clone
- (Self : Query_Predicate) return Query_Predicate;
- -- Return a copy of the given Query_Predicate
-
- overriding procedure Release (Self : in out Query_Predicate);
-
- --------------------------------
- -- Chained_Pattern_Query_Iter --
- --------------------------------
-
- type Chained_Pattern_Query_Iter is new Lk_Node_Iterator with record
- Ctx : Eval_Context;
- Iter : Chained_Pattern_Iterator;
- end record;
-
- overriding function Next (Iter : in out Chained_Pattern_Query_Iter;
- Result : out Lk_Node) return Boolean;
-
- overriding function Clone (Iter : Chained_Pattern_Query_Iter)
- return Chained_Pattern_Query_Iter;
-
- overriding procedure Release (Iter : in out Chained_Pattern_Query_Iter);
-
-end LKQL.Queries;
diff --git a/lkql/extensions/src/lkql-selector_lists.adb b/lkql/extensions/src/lkql-selector_lists.adb
deleted file mode 100644
index f40619314..000000000
--- a/lkql/extensions/src/lkql-selector_lists.adb
+++ /dev/null
@@ -1,227 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package body LKQL.Selector_Lists is
-
- -----------
- -- Nodes --
- -----------
-
- function Nodes (Self : Selector_List) return Lk_Node_Vector is
- Depth_Node_Values : constant Depth_Node_Vector := Self.Depth_Nodes;
- begin
- return Result : Lk_Node_Vector do
- for El of Depth_Node_Values loop
- Result.Append (El.Node);
- end loop;
- end return;
- end Nodes;
-
- ------------
- -- Values --
- ------------
-
- function Depth_Nodes (Self : Selector_List) return Depth_Node_Vector is
- (Self.Data.Get.Values);
-
- ---------------
- -- Max_Depth --
- ---------------
-
- function Max_Depth (Self : Selector_List) return Natural is
- (Self.Data.Get.Get_Max_Depth);
-
- ------------
- -- Length --
- ------------
-
- function Length (Self : Selector_List) return Natural is
- (Self.Data.Get.Get_Total_Length);
-
- ----------
- -- Next --
- ----------
-
- function Next
- (Self : in out Selector_List; Result : out Depth_Node) return Boolean
- is
- use Depth_Node_Iters.Element_Options;
- Element : constant Option := Self.Data.Get.Nth_Node (Self.Next_Pos);
- begin
- if Is_Some (Element) then
- Self.Next_Pos := Self.Next_Pos + 1;
- Result := Extract (Element);
- end if;
-
- return Is_Some (Element);
- end Next;
-
- -----------
- -- Clone --
- -----------
-
- function Clone (Self : Selector_List) return Selector_List is
- Data_Ref : constant Shared_Data_Ref := Self.Data;
- begin
- return Selector_List'(Data_Ref, Positive'First);
- end Clone;
-
- ------------------------
- -- Make_Selector_List --
- ------------------------
-
- function Make_Selector_List
- (Iter : Depth_Node_Iter_Access) return Selector_List
- is
- (Data => Make_Shared_Data (Iter),
- Next_Pos => Positive'First);
-
- ------------
- -- Values --
- ------------
-
- function Values
- (Data : in out Selector_Shared_Data) return Depth_Node_Vector
- is
- use Depth_Node_Iters.Element_Options;
- Current_Pos : Positive := 1;
- Current_Element : Option := Data.Nth_Node (Current_Pos);
- begin
- return Elements_Vec : Depth_Node_Vector do
- while Is_Some (Current_Element) loop
- Elements_Vec.Append (Extract (Current_Element));
- Current_Pos := Current_Pos + 1;
- Current_Element := Data.Nth_Node (Current_Pos);
- end loop;
- end return;
- end Values;
-
- --------------
- -- Nth_Node --
- --------------
-
- function Nth_Node (Data : in out Selector_Shared_Data;
- N : Positive) return Depth_Node_Iters.Element_Option
- is
- use Depth_Node_Iters.Element_Options;
- Element : constant Option := Data.Iter.Get_Cached (N);
- begin
- return (if Is_Some (Element) then Element
- else Draw_N_From_Iter (Data, N - Data.Iter.Cache_Length));
- end Nth_Node;
-
- ----------------------
- -- Draw_N_From_Iter --
- ----------------------
-
- function Draw_N_From_Iter (Data : in out Selector_Shared_Data;
- N : Positive)
- return Depth_Node_Iters.Element_Option
- is
- use Depth_Node_Iters.Element_Options;
- Element : Depth_Node;
- Remaining : Natural := N;
- begin
- while Remaining > 0 and then Data.Iter.Next (Element) loop
- Remaining := Remaining - 1;
- end loop;
-
- return (if Remaining = 0 then To_Option (Element)
- else None);
- end Draw_N_From_Iter;
-
- ----------------------
- -- Get_Total_Length --
- ----------------------
-
- function Get_Total_Length (Data : in out Selector_Shared_Data)
- return Natural
- is
- begin
- if Data.Total_Length = -1 then
- Data.Total_Length := Integer (Data.Values.Length);
- end if;
-
- return Data.Total_Length;
- end Get_Total_Length;
-
- -------------------
- -- Get_Max_Depth --
- -------------------
-
- function Get_Max_Depth (Data : in out Selector_Shared_Data) return Natural
- is
- Max : Natural := 0;
- begin
- if Data.Max_Depth = -1 then
- for N of Data.Values loop
- if N.Depth > Max then
- Max := N.Depth;
- end if;
- end loop;
-
- Data.Max_Depth := Max;
- end if;
-
- return Data.Max_Depth;
- end Get_Max_Depth;
-
- --------------------
- -- Filtered_Count --
- --------------------
-
- function Filtered_Count (Data : in out Selector_Shared_Data) return Natural
- is
- Inner : constant Depth_Node_Iters.Filter_Iter :=
- Depth_Node_Iters.Filter_Iter (Data.Iter.Get_Inner.all);
- begin
- return Inner.Filtered_Count;
- end Filtered_Count;
-
- -------------
- -- Release --
- -------------
-
- procedure Release (Data : in out Selector_Shared_Data) is
- begin
- Data.Iter.Release;
- end Release;
-
- ----------------------
- -- Make_Shared_Data --
- ----------------------
-
- function Make_Shared_Data
- (Iter : Depth_Node_Iter_Access) return Shared_Data_Ref
- is
- Resetable : constant Depth_Node_Iters.Resetable_Iter :=
- Depth_Node_Iters.Resetable (Depth_Node_Iters.Iterator_Access (Iter));
- Data : constant Selector_Shared_Data :=
- (Refcounted with Iter => Resetable, others => <>);
- begin
- return Result : Shared_Data_Ref do
- Result.Set (Data);
- end return;
- end Make_Shared_Data;
-
-end LKQL.Selector_Lists;
diff --git a/lkql/extensions/src/lkql-selector_lists.ads b/lkql/extensions/src/lkql-selector_lists.ads
deleted file mode 100644
index a29f12dc8..000000000
--- a/lkql/extensions/src/lkql-selector_lists.ads
+++ /dev/null
@@ -1,134 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Depth_Nodes; use LKQL.Depth_Nodes;
-with GNATCOLL.Refcount; use GNATCOLL.Refcount;
-
-package LKQL.Selector_Lists is
-
- type Selector_List is new Depth_Node_Iter with private;
-
- function Nodes (Self : Selector_List) return Lk_Node_Vector;
- -- Return an array containing the Ada_Node values returned by the selector
- ---
- -- NOTE that this will consume the entire selector.
-
- function Depth_Nodes (Self : Selector_List) return Depth_Node_Vector;
- -- Return an array containing the Depth_Node values returned by the
- -- selector.
- ---
- -- NOTE that this will consume the entire selector.
-
- function Max_Depth (Self : Selector_List) return Natural;
- -- Return the depth of the 'deepest' node return by the selector
- ---
- -- NOTE that this will consume the entire selector.
-
- function Length (Self : Selector_List) return Natural;
- -- Return the number of nodes returned by the selector.
- ---
- -- NOTE that this will consume the entire selector.
-
- overriding function Next
- (Self : in out Selector_List; Result : out Depth_Node) return Boolean;
-
- overriding function Clone (Self : Selector_List) return Selector_List;
-
- type Depth_Node_Filter_Access is
- not null access all Depth_Node_Iters.Filter_Iter;
-
- function Make_Selector_List
- (Iter : Depth_Node_Iter_Access) return Selector_List;
- -- Return a Selector_List wrapping the given iterator
-
-private
-
- --------------------------
- -- Selector_Shared_Data --
- --------------------------
-
- subtype Optionnal_Natural is Integer range -1 .. Integer'Last;
- -- Subtype used to represent optional Natural values.
- -- A value of -1 is equivalent to 'None'.
-
- type Selector_Shared_Data is new Refcounted with record
- Iter : Depth_Node_Iters.Resetable_Iter;
- -- Iterator yielding the selector values
- Max_Depth : Optionnal_Natural := -1;
- -- Maximum depth of the selector values
- Total_Length : Optionnal_Natural := -1;
- -- Total number of elements that belong to the result set of the
- -- selector.
- end record;
- -- Data shared by multiple references to the same selector list
-
- function Values
- (Data : in out Selector_Shared_Data) return Depth_Node_Vector;
- -- Return the nodes yielded by the selector
-
- function Nth_Node (Data : in out Selector_Shared_Data;
- N : Positive) return Depth_Node_Iters.Element_Option;
- -- Return the nth node yielded by the selector, if any
-
- function Draw_N_From_Iter (Data : in out Selector_Shared_Data;
- N : Positive)
- return Depth_Node_Iters.Element_Option;
- -- Draw N nodes from the wrapped iterator and return the nth drawn node,
- -- if any.
- -- All drawn nodes will be stored in the cache.
-
- function Get_Total_Length (Data : in out Selector_Shared_Data)
- return Natural;
- -- Return the total number of nodes returned by the selector
-
- function Get_Max_Depth (Data : in out Selector_Shared_Data) return Natural;
- -- Return the depth of the deepest node returned by the selector.
-
- function Filtered_Count (Data : in out Selector_Shared_Data) return Natural
- with Pre => Data.Iter.Get_Inner.all in Depth_Node_Iters.Filter_Iter;
- -- Return the number of nodes that didn't match the selector predicate
-
- procedure Release (Data : in out Selector_Shared_Data);
- -- Release the Selector_Shared_Data's value memory
-
- package Shared_Data_Ptrs is new Shared_Pointers
- (Element_Type => Selector_Shared_Data,
- Release => Release);
-
- subtype Shared_Data_Ref is Shared_Data_Ptrs.Ref;
-
- function Make_Shared_Data
- (Iter : Depth_Node_Iter_Access) return Shared_Data_Ref;
-
- -------------------
- -- Selector_List --
- -------------------
-
- type Selector_List is new Depth_Node_Iter with record
- Data : Shared_Data_Ref;
- -- Pointer to the actual data.
- Next_Pos : Positive;
- -- Position of the next element to be
- end record;
-
-end LKQL.Selector_Lists;
diff --git a/lkql/extensions/src/lkql-string_utils.adb b/lkql/extensions/src/lkql-string_utils.adb
deleted file mode 100644
index 1b0c978e5..000000000
--- a/lkql/extensions/src/lkql-string_utils.adb
+++ /dev/null
@@ -1,148 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Strings;
-with Ada.Wide_Wide_Characters.Unicode; use Ada.Wide_Wide_Characters.Unicode;
-with Ada.Strings.Wide_Wide_Unbounded; use Ada.Strings.Wide_Wide_Unbounded;
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with System.Address_Image;
-
-package body LKQL.String_Utils is
-
- function Make_Underlining (Left_Padding : Natural;
- Underlining : Natural;
- Right_Padding : Natural)
- return Unbounded_Text_Type;
-
- ----------------------
- -- Make_Underlining --
- ----------------------
-
- function Make_Underlining (Left_Padding : Natural;
- Underlining : Natural;
- Right_Padding : Natural)
- return Unbounded_Text_Type
- is
- begin
- return (Left_Padding * ' ') &
- (Underlining * '^') &
- (Right_Padding * ' ');
- end Make_Underlining;
-
- -----------------
- -- Split_Lines --
- -----------------
-
- function Split_Lines (Str : Text_Type) return String_Vectors.Vector is
- Start : Positive := Str'First;
- Result : String_Vectors.Vector;
- begin
- for I in Str'First .. Str'Last + 1 loop
- if I = Str'Last + 1 or else Is_Line_Terminator (Str (I)) then
- Result.Append (To_Unbounded_Text (Str (Start .. I - 1)));
- Start := I + 1;
- end if;
- end loop;
-
- return Result;
- end Split_Lines;
-
- ---------------------
- -- Underline_Range --
- ---------------------
-
- function Underline_Range (Line : Unbounded_Text_Type;
- Start : Positive;
- Stop : Positive) return Unbounded_Text_Type
- is
- use Langkit_Support.Text.Chars;
- Actual_Start : constant Integer :=
- Integer'Max (Start, Index_Non_Blank (Line));
- Actual_Stop : constant Integer :=
- Integer'Min (Stop, Index_Non_Blank (Line, Ada.Strings.Backward));
- Left : constant Natural :=
- Integer'Max (0, Actual_Start - 1);
- Underlining : constant Natural := Actual_Stop - Actual_Start + 1;
- Right : constant Natural := Length (Line) - Actual_Stop;
- begin
- if Actual_Stop <= Actual_Start then
- return Line;
- end if;
- return Line & LF & Make_Underlining (Left, Underlining, Right) & LF;
- end Underline_Range;
-
- --------------------
- -- Underline_From --
- --------------------
-
- function Underline_From (Line : Unbounded_Text_Type;
- Start : Positive) return Unbounded_Text_Type
- is
- Stop : constant Integer := Index_Non_Blank (Line, Ada.Strings.Backward);
- begin
- return Underline_Range (Line, Start, Stop);
- end Underline_From;
-
- ------------------
- -- Underline_To --
- ------------------
-
- function Underline_To (Line : Unbounded_Text_Type;
- Stop : Positive) return Unbounded_Text_Type
- is
- Start : constant Integer := Index_Non_Blank (Line);
- begin
- return Underline_Range (Line, Start, Stop);
- end Underline_To;
-
- ---------------
- -- Underline --
- ---------------
-
- function Underline
- (Line : Unbounded_Text_Type) return Unbounded_Text_Type
- is
- Start : constant Integer := Index_Non_Blank (Line);
- Stop : constant Integer := Index_Non_Blank (Line, Ada.Strings.Backward);
- begin
- return (if Start < 1 or else Stop < 1 or else Stop <= Start then Line
- else Underline_Range (Line, Start, Stop));
- end Underline;
-
- -------------------
- -- Address_Image --
- -------------------
-
- function Address_Image (Addr : System.Address) return String is
- Ret : constant String := System.Address_Image (Addr);
- I : Natural := 0;
- begin
- for C of Ret loop
- exit when C /= '0';
- I := I + 1;
- end loop;
-
- return To_Lower (Ret (Natural'Min (Ret'Last, I + 1) .. Ret'Last));
- end Address_Image;
-
-end LKQL.String_Utils;
diff --git a/lkql/extensions/src/lkql-string_utils.ads b/lkql/extensions/src/lkql-string_utils.ads
deleted file mode 100644
index 4218b82c2..000000000
--- a/lkql/extensions/src/lkql-string_utils.ads
+++ /dev/null
@@ -1,82 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-with Ada.Containers.Hashed_Sets;
-with Ada.Containers.Vectors; use Ada.Containers;
-with System;
-
-package LKQL.String_Utils is
-
- package String_Vectors is new Vectors (Positive, Unbounded_Text_Type);
-
- subtype String_Vector is String_Vectors.Vector;
- -- Vector of Unbouted_Text_type values
-
- package Symbol_Sets is new Ada.Containers.Hashed_Sets
- (Element_Type => Symbol_Type,
- Hash => Hash,
- Equivalent_Elements => "=");
-
- subtype Symbol_Set is Symbol_Sets.Set;
- -- Set of Unbounded_Text_Type values
-
- function Split_Lines (Str : Text_Type) return String_Vectors.Vector;
- -- Return a list of the lines in the given string
-
- function Underline_Range (Line : Unbounded_Text_Type;
- Start : Positive;
- Stop : Positive) return Unbounded_Text_Type;
- -- Return Line plus a new line character and a sequence characters so that
- -- all non-whitespace columns between `Start` and `Stop` (included) are '^'
- -- and the other columns are spaces.
- --
- -- The input must contain a single line of text.
-
- function Underline_From (Line : Unbounded_Text_Type;
- Start : Positive) return Unbounded_Text_Type;
- -- Return Line plus a new line character and a sequence characters so that
- -- all non-whitespace columns from `Start` to the end of the line are
- -- '^' and the other columns are spaces.
- --
- -- The input must contain a single line of text.
-
- function Underline_To (Line : Unbounded_Text_Type;
- Stop : Positive) return Unbounded_Text_Type;
- -- Return Line plus a new line character and a sequence characters so that
- -- all non-whitespace columns from the beginning of the line to `Stop` are
- -- '^' and the other columns are spaces.
- --
- -- The input must contain a single line of text.
-
- function Underline (Line : Unbounded_Text_Type) return Unbounded_Text_Type;
- -- Underline all the text in the input String. The input must contain a
- -- single line of text.
-
- function Address_Image (Addr : System.Address) return String;
- -- "Better" version of ``System.Address_Image``, that will strip leading
- -- zeros, and put hex letters in lowercase, yielding shorter & more
- -- readable addresses.
-
-end LKQL.String_Utils;
diff --git a/lkql/extensions/src/lkql-unit_utils.adb b/lkql/extensions/src/lkql-unit_utils.adb
deleted file mode 100644
index ef9dd68c9..000000000
--- a/lkql/extensions/src/lkql-unit_utils.adb
+++ /dev/null
@@ -1,364 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Directories; use Ada.Directories;
-with Ada.Strings.Wide_Wide_Unbounded;
-with Ada.Strings.Wide_Wide_Fixed; use Ada.Strings.Wide_Wide_Fixed;
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-with Langkit_Support.Diagnostics; use Langkit_Support.Diagnostics;
-with Langkit_Support.Diagnostics.Output;
-
-with LKQL.Node_Extensions; use LKQL.Node_Extensions;
-with GNAT.Regpat;
-
-package body LKQL.Unit_Utils is
-
- procedure Output_Error (Node : L.Lkql_Node; Error_Msg : Text_Type);
-
- function Preprocess_String (S : Text_Type) return Text_Type;
- -- Preprocess the given text, which is the content of a string literal.
- -- Today, this is solely processing escape sequences.
-
- ------------------
- -- Output_Error --
- ------------------
-
- procedure Output_Error (Node : L.Lkql_Node; Error_Msg : Text_Type) is
- D : constant Diagnostic := Langkit_Support.Diagnostics.Create
- (Sloc_Range => Node.Sloc_Range,
- Message => Error_Msg);
- begin
- Output.Print_Diagnostic
- (D, Node.Unit, Simple_Name (Node.Unit.Get_Filename));
- raise Unit_Creation_Error;
- end Output_Error;
-
- -----------------------
- -- Preprocess_String --
- -----------------------
-
- function Preprocess_String (S : Text_Type) return Text_Type is
- Ret : Unbounded_Text_Type;
- Idx : Positive := S'First;
-
- function Decode_Hex (C : Wide_Wide_Character) return Natural
- is (case C is
- when '0' .. '9' =>
- Wide_Wide_Character'Pos (C) - Wide_Wide_Character'Pos ('0'),
- when 'a' .. 'f' =>
- 10 + Wide_Wide_Character'Pos (C) - Wide_Wide_Character'Pos ('a'),
- when 'A' .. 'F' =>
- 10 + Wide_Wide_Character'Pos (C) - Wide_Wide_Character'Pos ('A'),
- when others =>
- raise Unit_Creation_Error with "Invalid escape character");
- -- Return the integer value corresponding to the given heaxdecimal
- -- character.
-
- use Ada.Strings.Wide_Wide_Unbounded;
- begin
- -- Process escape sequences
- loop
- exit when Idx > S'Last;
- if S (Idx) = '\' then
- case S (Idx + 1) is
-
- -- Just append the escaped character
- when '\' | '"' => Append (Ret, S (Idx + 1));
-
- -- Newline \n: append a LF char
- when 'n' => Append (Ret, To_Text ((1 => ASCII.LF)));
-
- -- Hex code
- when 'x' =>
- Idx := Idx + 2;
- Append (Ret,
- Wide_Wide_Character'Val
- (Decode_Hex (S (Idx)) * 16 +
- Decode_Hex (S (Idx + 1))));
-
- -- Unsupported cases
- when others =>
- raise Unit_Creation_Error
- with "Unsupported escape character";
- end case;
-
- Idx := Idx + 2;
-
- else
- Append (Ret, S (Idx));
- Idx := Idx + 1;
- end if;
- end loop;
-
- return To_Text (Ret);
- end Preprocess_String;
-
- ----------------------
- -- Run_Preprocessor --
- ----------------------
-
- procedure Run_Preprocessor
- (Context : Eval_Context; Unit : L.Analysis_Unit)
- is
-
- function Preprocess_Visitor
- (Node : L.Lkql_Node'Class) return LCO.Visit_Status;
- -- Visitor for the preprocessing pass of LKQL, where we will do some
- -- preprocessing/compilation like computations. TODO: For the moment
- -- this is in unit utils, but clearly this should have its own
- -- dedicated module eventually.
-
- ------------------------
- -- Preprocess_Visitor --
- ------------------------
-
- function Preprocess_Visitor
- (Node : L.Lkql_Node'Class) return LCO.Visit_Status
- is
- begin
- L.Init_Extension (Node);
-
- declare
- Ext_Val : constant Ext := Get_Ext (Node);
- begin
- case Node.Kind is
-
- when LCO.Lkql_Base_Function =>
-
- -- Base function case: Pre process function parameters, put
- -- them in a name -> info map so that we can speed up function
- -- calls.
-
- Ext_Val.Content :=
- Node_Ext'(Kind => LCO.Lkql_Anonymous_Function, Params => <>);
- declare
- Fun : constant L.Parameter_Decl_List
- := Node.As_Base_Function.F_Parameters;
- begin
- for I in Fun.First_Child_Index .. Fun.Last_Child_Index loop
- declare
- Param : constant L.Parameter_Decl :=
- Fun.Child (I).As_Parameter_Decl;
- begin
- Ext_Val.Content.Params.Include
- (Symbol (Param.F_Param_Identifier), (Param, I));
- end;
- end loop;
- end;
-
- when LCO.Lkql_Fun_Call =>
-
- -- Function calls: Check that positional arguments are always
- -- before named arguments.
- declare
- Has_Seen_Named : Boolean := False;
- begin
- for Arg of Node.As_Fun_Call.F_Arguments loop
- case Arg.Kind is
- when LCO.Lkql_Named_Arg =>
- Has_Seen_Named := True;
- when LCO.Lkql_Expr_Arg =>
- if Has_Seen_Named then
- Output_Error
- (Arg.As_Lkql_Node,
- "positional argument after named argument");
- end if;
- when others => null;
- end case;
- end loop;
- end;
-
- when LCO.Lkql_Regex_Pattern =>
-
- -- Regular expressions: precompile regex patterns to speed up
- -- matching at runtime.
- declare
- use GNAT.Regpat;
- use Ada.Strings.Wide_Wide_Unbounded;
-
- Regex_Node : constant L.Regex_Pattern
- := Node.As_Regex_Pattern;
-
- Quoted_Pattern : constant Unbounded_Text_Type :=
- To_Unbounded_Text (Regex_Node.Text);
-
- Pattern_Str : constant Unbounded_Text_Type :=
- Unbounded_Slice
- (Quoted_Pattern, 2, Length (Quoted_Pattern) - 1);
-
- Pattern_Utf8 : constant String :=
- To_UTF8 (To_Text (Pattern_Str));
- begin
- Ext_Val.Content := Node_Ext'
- (Kind => LCO.Lkql_Regex_Pattern,
- Compiled_Pattern =>
- new Pattern_Matcher'(Compile (Pattern_Utf8)));
- exception
- when Expression_Error =>
- Output_Error
- (Node.As_Lkql_Node,
- "Failed to compile regular expression: " &
- To_Text (Pattern_Str));
- end;
-
- when LCO.Lkql_Node_Kind_Pattern =>
- declare
- Pattern : constant L.Node_Kind_Pattern :=
- Node.As_Node_Kind_Pattern;
-
- T : constant LKI.Type_Ref :=
- Context.Get_Name_Map.Lookup_Type
- (Context.Symbol (Pattern.F_Kind_Name.Text));
-
- use LKI;
- begin
- if T = LKI.No_Type_Ref then
- Output_Error (Node.As_Lkql_Node, "Invalid kind name");
- end if;
-
- Ext_Val.Content := Node_Ext'
- (Kind => LCO.Lkql_Node_Kind_Pattern,
- Expected_Type => T);
- end;
-
- when LCO.Lkql_String_Literal =>
- declare
- T : Text_Type renames Node.Text;
- No_Quotes : constant Text_Type :=
- T (T'First + 1 .. T'Last - 1);
- begin
- Ext_Val.Content :=
- Node_Ext'
- (Kind => LCO.Lkql_String_Literal,
- Denoted_Value =>
- new Text_Type'(Preprocess_String (No_Quotes)));
- end;
- when LCO.Lkql_Block_String_Literal =>
- declare
- Ret : Unbounded_Text_Type;
- package W renames Ada.Strings.Wide_Wide_Unbounded;
- begin
- if Node.Children_Count > 0 then
- -- The block string will be aligned on the start of the
- -- first non blank char of the first block literal
- declare
- First_Sub_Block : constant L.Sub_Block_Literal :=
- Node.As_Block_String_Literal
- .F_Docs.Child (1).As_Sub_Block_Literal;
- Text : constant Text_Type :=
- First_Sub_Block.Text;
-
- Stripped : constant Text_Type :=
- Text (Text'First + 2 .. Text'Last);
- -- Strip the |" prefix
-
- Non_Blank_Index : constant Positive :=
- Index_Non_Blank (Stripped) - Text'First;
- -- Get the first non blank index
- begin
- for Doc_Lit of
- Node.As_Block_String_Literal.F_Docs.Children
- loop
- declare
- T : constant Text_Type := Doc_Lit.Text;
- begin
- W.Append
- (Ret,
- To_Unbounded_Text
- (T (T'First + Non_Blank_Index .. T'Last)));
- W.Append (Ret, To_Text ("" & ASCII.LF));
- end;
- end loop;
- end;
- end if;
- Ext_Val.Content :=
- Node_Ext'
- (Kind => LCO.Lkql_Block_String_Literal,
- Denoted_Value =>
- new Text_Type'(Preprocess_String (To_Text (Ret))));
- end;
- when others => null;
- end case;
- end;
-
- return LCO.Into;
- end Preprocess_Visitor;
- begin
- -- TODO: Ideally we would check here that the unit has not already
- -- been preprocessed.
- Unit.Root.Traverse (Preprocess_Visitor'Access);
- end Run_Preprocessor;
-
- --------------------
- -- Make_Lkql_Unit --
- --------------------
-
- function Make_Lkql_Unit
- (Eval_Ctx : Eval_Context;
- Path : String) return L.Analysis_Unit
- is
- Ret : constant L.Analysis_Unit :=
- Unit_Or_Error (Get_Context (Eval_Ctx.Kernel.all).Get_From_File (Path));
- begin
- Run_Preprocessor (Eval_Ctx, Ret);
- return Ret;
- end Make_Lkql_Unit;
-
- ------------------------------
- -- Make_Lkql_Unit_From_Code --
- ------------------------------
-
- function Make_Lkql_Unit_From_Code
- (Eval_Ctx : Eval_Context;
- Lkql_Code : String;
- Unit_Name : String := "[inline code]") return L.Analysis_Unit
- is
- Ret : constant L.Analysis_Unit := Unit_Or_Error
- (Get_Context (Eval_Ctx.Kernel.all).Get_From_Buffer
- (Filename => Unit_Name, Buffer => Lkql_Code));
- begin
- Run_Preprocessor (Eval_Ctx, Ret);
- return Ret;
- end Make_Lkql_Unit_From_Code;
-
- -------------------
- -- Unit_Or_Error --
- -------------------
-
- function Unit_Or_Error (Unit : L.Analysis_Unit) return L.Analysis_Unit is
- begin
- if Unit.Has_Diagnostics then
- for D of Unit.Diagnostics loop
- Output.Print_Diagnostic
- (D, Unit, Simple_Name (Unit.Get_Filename));
- end loop;
-
- raise Unit_Creation_Error;
- end if;
-
- Unit.Populate_Lexical_Env;
- return Unit;
- end Unit_Or_Error;
-
-end LKQL.Unit_Utils;
diff --git a/lkql/extensions/src/lkql-unit_utils.ads b/lkql/extensions/src/lkql-unit_utils.ads
deleted file mode 100644
index cfbb073a3..000000000
--- a/lkql/extensions/src/lkql-unit_utils.ads
+++ /dev/null
@@ -1,56 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-
-package LKQL.Unit_Utils is
-
- Unit_Creation_Error : exception;
-
- procedure Run_Preprocessor
- (Context : Eval_Context; Unit : L.Analysis_Unit);
- -- Run LKQL preprocessor on the unit, which associates precomputed data
- -- to key nodes in order to accelerate runtime evaluation. This phase is
- -- required for all units that must be evaluated. It is already performed
- -- by the routines defined below.
-
- function Make_Lkql_Unit
- (Eval_Ctx : Eval_Context;
- Path : String) return L.Analysis_Unit;
- -- Create an LKQL analysis unit in the context 'Context' from the given
- -- file.
-
- function Make_Lkql_Unit_From_Code
- (Eval_Ctx : Eval_Context;
- Lkql_Code : String;
- Unit_Name : String := "[inline code]") return L.Analysis_Unit;
- -- Create an LKQL analysis unit in the context 'Context' from the given
- -- Lkql_Code.
-
-private
-
- function Unit_Or_Error (Unit : L.Analysis_Unit) return L.Analysis_Unit;
- -- If 'Unit' has diagnostics raise a Unit_Create_Error, otherwise return
- -- 'Unit'.
-
-end LKQL.Unit_Utils;
diff --git a/lkql/extensions/src/lkql.adb b/lkql/extensions/src/lkql.adb
deleted file mode 100644
index 027f8813b..000000000
--- a/lkql/extensions/src/lkql.adb
+++ /dev/null
@@ -1,47 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Langkit_Support.Text; use Langkit_Support.Text;
-
-package body LKQL is
- ---------------
- -- Node_Text --
- ---------------
-
- function Node_Text (Self : L.Lkql_Node'Class) return String is
- begin
- return Image (L.Text (Self));
- end Node_Text;
-
- ------------
- -- Symbol --
- ------------
-
- function Symbol (Node : L.Identifier) return Symbol_Type is
- begin
- return (if Node.Is_Null
- then null
- else LCO.Get_Symbol (Node.Token_Start));
- end Symbol;
-
-end LKQL;
diff --git a/lkql/extensions/src/lkql.ads b/lkql/extensions/src/lkql.ads
deleted file mode 100644
index 1e14ebe45..000000000
--- a/lkql/extensions/src/lkql.ads
+++ /dev/null
@@ -1,53 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Liblkqllang.Analysis;
-with Liblkqllang.Common;
-with Langkit_Support.Symbols; use Langkit_Support.Symbols;
-with Langkit_Support.Generic_API.Analysis;
-with Langkit_Support.Generic_API.Introspection;
-use Langkit_Support.Generic_API.Analysis;
-with Langkit_Support.Names;
-with Langkit_Support.Errors;
-
-with Ada.Containers.Vectors;
-
-package LKQL is
- package L renames Liblkqllang.Analysis;
- package LCO renames Liblkqllang.Common;
- package LK renames Langkit_Support.Generic_API.Analysis;
- package LKI renames Langkit_Support.Generic_API.Introspection;
- package LKN renames Langkit_Support.Names;
- package LKE renames Langkit_Support.Errors;
-
- function Node_Text (Self : L.Lkql_Node'Class) return String;
- -- Helper debug function. Return the text of a node as a string.
-
- function Symbol (Node : L.Identifier) return Symbol_Type;
-
- package Lk_Node_Vectors is new Ada.Containers.Vectors
- (Positive, Langkit_Support.Generic_API.Analysis.Lk_Node);
-
- subtype Lk_Node_Vector is Lk_Node_Vectors.Vector;
-
-end LKQL;
diff --git a/lkql/extensions/src/options.adb b/lkql/extensions/src/options.adb
deleted file mode 100644
index 643c6a308..000000000
--- a/lkql/extensions/src/options.adb
+++ /dev/null
@@ -1,57 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-package body Options is
-
- -------------
- -- Is_Some --
- -------------
-
- function Is_Some (Self : Option) return Boolean is (Self.Kind = Kind_Some);
-
- -------------
- -- Is_None --
- -------------
-
- function Is_None (Self : Option) return Boolean is (Self.Kind = Kind_None);
-
- -------------
- -- Extract --
- -------------
-
- function Extract (Self : Option) return Value_Type is (Self.Value);
-
- ---------------
- -- To_Option --
- ---------------
-
- function To_Option (Value : Value_Type) return Option is
- (Option'(Kind_Some, Value));
-
- ----------
- -- None --
- ----------
-
- function None return Option is (Option'(Kind => Kind_None));
-
-end Options;
diff --git a/lkql/extensions/src/options.ads b/lkql/extensions/src/options.ads
deleted file mode 100644
index 22e7d0532..000000000
--- a/lkql/extensions/src/options.ads
+++ /dev/null
@@ -1,72 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
--- This package provides a generic 'Option' type, meant to represent optional
--- values.
-
-generic
-
- type Value_Type is private;
- -- Type of the optional value
-
-package Options is
-
- type Option_Kind is
- (Kind_None,
- -- The Option doesn't contains a value
- Kind_Some
- -- The Option contains a value
- );
-
- type Option (Kind : Option_Kind := Kind_None) is private;
- -- Stores an optional value
-
- function Is_Some (Self : Option) return Boolean;
- -- Return True if the option contains a value
-
- function Is_None (Self : Option) return Boolean;
- -- Return True if the option doesn't contain a value
-
- function Extract (Self : Option) return Value_Type
- with Pre => Self.Kind = Kind_Some;
- -- Return the wrapped value, if any.
- -- An Assertion_Error will be raised if there is no value.
-
- function To_Option (Value : Value_Type) return Option;
- -- Create an Option value that contains the given value
-
- function None return Option;
- -- Create an Option that doesn't contain a value
-
-private
-
- type Option (Kind : Option_Kind := Kind_None) is record
- case Kind is
- when Kind_None =>
- null;
- when Kind_Some =>
- Value : Value_Type;
- end case;
- end record;
-
-end Options;
diff --git a/lkql/extensions/src/unbounded_holders.adb b/lkql/extensions/src/unbounded_holders.adb
deleted file mode 100644
index c136264af..000000000
--- a/lkql/extensions/src/unbounded_holders.adb
+++ /dev/null
@@ -1,102 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2021-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Conversion;
-
-package body Unbounded_Holders is
-
- package body Holders_Impl is
-
- use System.Storage_Elements;
-
- ---------
- -- Get --
- ---------
-
- function Unchecked_Get (Self : Holders.Holder) return T_Access is
- use Holders;
- subtype Sized_Buffer is Unsized_Buffer (0 .. Self.Real_Size);
- Buffer : Sized_Buffer;
- for Buffer'Address use Self.Buffer'Address;
-
- function To_T_Access is new Ada.Unchecked_Conversion
- (System.Address, T_Access);
- begin
- return To_T_Access (Buffer'Address);
- end Unchecked_Get;
-
- ------------
- -- Create --
- ------------
-
- function Create (Value : T) return Holders.Holder is
- Size_In_Storage_Elements : constant Storage_Count
- := Value'Size / System.Storage_Unit;
- begin
- if Size_In_Storage_Elements > Holders.Max_Size then
- raise Constraint_Error with
- "Value too big to be held in Holder (need "
- & Size_In_Storage_Elements'Image & ", got "
- & Holders.Max_Size'Image & ")";
- end if;
-
- declare
- pragma Warnings (Off, "program execution may be");
- Ret : Holders.Holder;
- Buffer : Holders.Internal_Buffer;
- for Buffer'Address use Value'Address;
- pragma Warnings (On, "program execution may be");
- begin
- for I in 0 .. Size_In_Storage_Elements loop
- Ret.Buffer (I) := Buffer (I);
- end loop;
- Ret.Real_Size := Size_In_Storage_Elements;
- return Ret;
- end;
- end Create;
-
- end Holders_Impl;
-
- package body Holders is
- -------------------
- -- Unchecked_Get --
- -------------------
-
- function Unchecked_Get (Self : Holder) return T_Access is
- begin
- return T_Access
- (Holders_Implem.Unchecked_Get
- (Holders_Implem.Holders.Holder (Self)));
- end Unchecked_Get;
-
- ------------
- -- Create --
- ------------
-
- function Create (Value : T) return Holder is
- begin
- return (Holders_Implem.Create (Value) with null record);
- end Create;
- end Holders;
-
-end Unbounded_Holders;
diff --git a/lkql/extensions/src/unbounded_holders.ads b/lkql/extensions/src/unbounded_holders.ads
deleted file mode 100644
index 774b8c5b9..000000000
--- a/lkql/extensions/src/unbounded_holders.ads
+++ /dev/null
@@ -1,148 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2021-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with System.Storage_Elements;
-
--- This package provides unbounded holders like the one that will be available
--- in Ada 2020
--- (see http://www.ada-auth.org/standards/2xaarm/html/AA-A-18-32.html).
--- However, we expose more details, in order to be able to use this with
--- incomplete types, despite the very flaky support of Ada for incomplete
--- types.
---
--- Using this for a regular type looks like::
---
--- type Root is tagged null record;
---
--- procedure Foo (Self : Root) is null;
---
--- type Derived is new Root with record
--- A, B : Integer;
--- end record;
---
--- type Derived_2 is new Derived with record
--- D, E : Integer;
--- end record;
---
--- ...
---
--- package Root_Holders is new Unbounded_Holders.Holder
--- (Root'Class, -- Type stored by the holder
--- 32 -- Maximum size of the holder
--- );
---
--- Inst : Root_Holders.Holder :=
--- Root_Holders.Create (Derived_2'(1, 2, 3, 4));
---
--- Inst.Unchecked_Get.Foo;
---
--- If you store an object bigger than the size of the holder, you'll get a
--- runtime exception.
---
--- For incomplete types, it will be a bit more complicated. You have to
--- manually instantiate Base_Holders::
---
--- package Root_Holders is new Unbounded_Holders.Base_Holders (32)
---
--- You can then declare the ``Create`` and ``Unchecked_Get`` operations
--- yourself in the spec:
---
--- function Create (Obj : Root'Class) return Root_Holders.Holder;
--- function Unchecked_Get (Holder: Root_Holders.Holder) return Root'Class;
---
--- And then, you'll instantiate the ``Holders_Impl`` yourself in the body, and
--- forward those implementations to your wrapper.
-
-package Unbounded_Holders is
-
- -- Base holder package. **You should not instantiate this except for the
- -- incomplete type use case**. Instead, use ``Holders``.
- generic
- Max_Size : System.Storage_Elements.Storage_Count;
- package Base_Holders is
-
- type Unsized_Buffer is array
- (System.Storage_Elements.Storage_Count range <>)
- of System.Storage_Elements.Storage_Element;
- -- Unsized buffer type, used to store the object internally.
-
- subtype Internal_Buffer is Unsized_Buffer (0 .. Max_Size);
- -- Buffer type sized to ``Max_Size``.
-
- type Holder is tagged record
- Buffer : Internal_Buffer;
- -- Buffer in which the objects are stored
-
- Real_Size : System.Storage_Elements.Storage_Count;
- -- Real size of the stored object. Used to reconstruct the object.
- end record;
-
- end Base_Holders;
-
- -- Holder's implementation package. **You should not instantiate this
- -- except for the incomplete type use case**. instead, use ``Holders``.
- generic
- type T (<>) is limited private;
- type T_Access is access all T;
- with package Holders is new Base_Holders (<>);
- package Holders_Impl is
- function Unchecked_Get (Self : Holders.Holder) return T_Access;
- function Create (Value : T) return Holders.Holder;
- end Holders_Impl;
-
- -- Main Holders package. See toplevel documentation for an example of use.
- generic
- type T (<>) is limited private;
- -- Type that the holder will hold.
-
- Max_Size : System.Storage_Elements.Storage_Count;
- -- Maximum size of the holder. If you try to store an object bigger than
- -- that, a ``Constraint_Error`` will be raised.
- package Holders is
-
- type Holder is tagged private;
- -- Main holder type. This object is ``Max_Size + Storage_Count'Size``
- -- big and holds the objects by value.
-
- type T_Access is access all T;
- -- Access type returned by the ``Unchecked_Get`` function below.
-
- function Unchecked_Get (Self : Holder) return T_Access;
- -- Return an access to the object stored inside the holder. This is an
- -- unsafe operation, but enough for our needs for now. If we want to
- -- make it safer we can add an Ada 2012 reference type.
-
- function Create (Value : T) return Holder;
- -- Create a holder from object ``Value``.
-
- private
-
- package T_Base_Holders is new Base_Holders (Max_Size);
-
- package Holders_Implem is new Holders_Impl
- (T, T_Access, T_Base_Holders);
-
- type Holder is new T_Base_Holders.Holder with null record;
- end Holders;
-
-end Unbounded_Holders;
diff --git a/lkql/language/parser.py b/lkql/language/parser.py
index eb577d70b..8d3ae8658 100644
--- a/lkql/language/parser.py
+++ b/lkql/language/parser.py
@@ -20,35 +20,7 @@ class LkqlNode(ASTNode):
"""
Root node class for LKQL AST nodes.
"""
-
- @langkit_property(public=True, return_type=T.Symbol.array,
- external=True, uses_envs=False, uses_entity_info=False)
- def interp_complete():
- """
- Complete from node.
- """
- pass
-
- @langkit_property(public=True, return_type=T.Bool,
- external=True, uses_envs=False, uses_entity_info=False)
- def interp_init_from_project(project_file=T.String):
- """
- Context method.
-
- Initialize the interpreter with given project file.
-
- TODO: add other project options
- """
- pass
-
- @langkit_property(public=True, return_type=T.Symbol,
- external=True, uses_envs=False, uses_entity_info=False)
- def interp_eval():
- """
- Eval the given node and return the result of the evaluation as a
- string.
- """
- pass
+ pass
class DeclAnnotation(LkqlNode):
diff --git a/lkql/manage.py b/lkql/manage.py
index 391c85ed0..8c0789121 100755
--- a/lkql/manage.py
+++ b/lkql/manage.py
@@ -9,7 +9,7 @@ class Manage(ManageScript):
@property
def main_programs(self):
- return super().main_programs | {'lkql_ada'}
+ return super().main_programs
def create_context(self, args):
@@ -23,9 +23,6 @@ def create_context(self, args):
lexer=lkql_lexer,
grammar=lkql_grammar)
- ctx.add_with_clause('Implementation', AdaSourceKind.body,
- 'Liblkqllang.Prelude', use_clause=True)
-
return ctx
diff --git a/lkql_checker/lkql_checker.gpr b/lkql_checker/gnatcheck.gpr
similarity index 78%
rename from lkql_checker/lkql_checker.gpr
rename to lkql_checker/gnatcheck.gpr
index 5d1ebd0c5..f6aca8bac 100644
--- a/lkql_checker/lkql_checker.gpr
+++ b/lkql_checker/gnatcheck.gpr
@@ -1,7 +1,8 @@
with "libadalang";
with "liblkqllang";
+with "gpr2";
-project Lkql_Checker is
+project GNATcheck is
type Build_Mode_Type is ("dev", "prod");
Build_Mode : Build_Mode_Type := external
@@ -10,10 +11,11 @@ project Lkql_Checker is
for Source_Dirs use ("src");
for Object_Dir use "obj/" & Build_Mode;
for Exec_Dir use "bin";
- for Main use ("lkql_checker.adb");
+ for Main use ("gnatcheck_main.adb");
package Builder is
- For Switches ("Ada") use ("-j0");
+ for Executable ("gnatcheck_main.adb") use "gnatcheck";
+ for Switches ("Ada") use ("-j0");
end Builder;
package Compiler is
@@ -28,4 +30,4 @@ project Lkql_Checker is
for Default_Switches ("Ada") use Switches;
end Compiler;
-end Lkql_Checker;
+end GNATcheck;
diff --git a/lkql_checker/lalcheck.gpr b/lkql_checker/lalcheck.gpr
deleted file mode 100644
index 3e9d6edc7..000000000
--- a/lkql_checker/lalcheck.gpr
+++ /dev/null
@@ -1,30 +0,0 @@
-with "libadalang";
-with "liblkqllang";
-with "lkql_checker";
-with "gpr2";
-
-project Lalcheck is
-
- for Source_Dirs use ("lalcheck");
- for Object_Dir use "obj/" & Lkql_Checker.Build_Mode;
- for Exec_Dir use "bin";
- for Main use ("lalcheck.adb");
-
- package Builder is
- for Executable ("lalcheck.adb") use "gnatcheck";
- for Switches ("Ada") use ("-j0");
- end Builder;
-
- package Compiler is
- Switches := ("-gnatyg", "-gnatwa", "-g", "-gnat2022");
- case Lkql_Checker.Build_Mode is
- when "dev" =>
- Switches := Switches & ("-O0", "-gnata", "-gnatwe");
- when "prod" =>
- Switches := Switches & ("-O2", "-gnatn2");
- end case;
-
- for Default_Switches ("Ada") use Switches;
- end Compiler;
-
-end Lalcheck;
diff --git a/lkql_checker/share/lkql/stdlib.lkql b/lkql_checker/share/lkql/stdlib.lkql
index 7590de014..12365a8d5 100644
--- a/lkql_checker/share/lkql/stdlib.lkql
+++ b/lkql_checker/share/lkql/stdlib.lkql
@@ -75,9 +75,9 @@ fun within_assert(node) =
fun ultimate_alias(name, all_nodes=true, strip_component=false) =
|" Return the ultimately designated ``ObjectDecl``, going through renamings
|" This will not go through generic instantiations. If all_nodes is true,
- |" consider all kinds of nodes, otherwise consider only BaseId and
- |" DottedName. If strip_component is true, go to the prefix when
- |" encountering a component, otherwise stop at the ComponentDecl.
+ |" consider all kinds of nodes, otherwise consider only ``BaseId`` and
+ |" ``DottedName``. If ``strip_component`` is true, go to the prefix when
+ |" encountering a component, otherwise stop at the ``ComponentDecl``.
if all_nodes or name is (BaseId or DottedName) then {
val decl = name.p_referenced_decl();
@@ -163,7 +163,7 @@ fun param_pos(n, pos: int = 0) =
# TODO: move this in LAL
fun is_predefined_op(op, follow_renamings=false) =
- |" Return true if op is a predefined operator
+ |" Return true if ``op`` is a predefined operator
{
val ref = op.p_referenced_decl();
val real_ref = if follow_renamings then ultimate_subprogram_alias(ref) else ref;
@@ -188,12 +188,12 @@ fun is_standard_numeric(n) =
n == "standard.duration"
fun is_standard_boolean(n) =
- |" Return true if the root type of n is Standard.Boolean
+ |" Return true if the root type of ``n`` is ``Standard.Boolean``.
n.p_expression_type() is t@BaseTypeDecl
when t.p_root_type() == n.p_bool_type()
fun full_root_type(t) =
- |" Return the full view of the root type of t, traversing subtypes,
+ |" Return the full view of the root type of ``t``, traversing subtypes,
|" derivations and privacy.
{
val res = t.p_root_type();
@@ -204,8 +204,8 @@ fun full_root_type(t) =
}
fun is_predefined_type(n) =
- |" Return true if n is the name of a type declared in a predefined package
- |" spec.
+ |" Return true if ``n`` is the name of a type declared in a predefined
+ |" package spec.
{
# Retrieve the root enclosing package
val packages = [
@@ -273,7 +273,8 @@ fun in_generic_template(n) =
}
fun enclosing_block(n) =
- |" Return the first DeclBlock enclosing n if any, null otherwise
+ |" Return the first ``DeclBlock`` enclosing ``n`` if any, ``null``
+ |" otherwise.
{
val block = [p for p in n.parents(include_self=false)
if p is DeclBlock]?[1];
@@ -504,9 +505,12 @@ fun has_interfaces(n) =
@memoized
fun propagate_exceptions(body) =
|" Return true if the given body may propagate an exception, namely if:
- |" - it has no exception handler with a "when others" choice;
+ |"
+ |" - it has no exception handler with a ``when others`` choice;
|" - or it has an exception handler containing a raise statement, or a call
- |" to Ada.Exception.Raise_Exception or Ada.Exception.Reraise_Occurrence.
+ |"
+ |" to ``Ada.Exception.Raise_Exception`` or
+ |" ``Ada.Exception.Reraise_Occurrence``.
not (# Look for a when others handler
[e for e in body.f_stmts.f_exceptions.children
if e is ExceptionHandler and
@@ -522,7 +526,8 @@ fun propagate_exceptions(body) =
name == "Ada.Exceptions.Reraise_Occurrence" }) == null)
fun is_by_copy(param) =
- |" Return true if ``param`` (a ParamActual) has a non aliased by-copy type
+ |" Return true if ``param`` (a ``ParamActual``) has a non aliased by-copy
+ |" type
not (param.param.parent.parent is ParamSpec(f_has_aliased is AliasedPresent)) and
param.actual.p_expression_type() is expr@BaseTypeDecl
when expr.p_root_type().p_full_view().p_root_type() is t@BaseTypeDecl
@@ -530,7 +535,7 @@ fun is_by_copy(param) =
t.p_is_fixed_point() or t.p_is_float_type()
fun get_parameter(params, actual) =
- |" Given a List[ParamActual], return the parameter corresponding to
+ |" Given a ``List[ParamActual]``, return the parameter corresponding to
|" actual, null if actual is not found.
{
fun find(params, actual, n) =
@@ -542,7 +547,7 @@ fun get_parameter(params, actual) =
@memoized
fun strip_conversions(node) =
- |" Strip ParenExpr, QualExpr and type conversions
+ |" Strip ``ParenExpr``, ``QualExpr`` and type conversions
match node
# Strip parenthesis
| ParenExpr => strip_conversions(node.f_expr)
@@ -554,15 +559,15 @@ fun strip_conversions(node) =
| * => node
fun ultimate_prefix(n) =
- |" Return n.f_prefix as long as n is a DottedName and designates a
- |" ComponentDecl, n otherwise.
+ |" Return ``n.f_prefix`` as long as ``n`` is a ``DottedName`` and
+ |" designates a ``ComponentDecl``, ``n`` otherwise.
if n is DottedName and n.p_referenced_decl() is ComponentDecl
then ultimate_prefix(n.f_prefix)
else n
@memoized
fun default_bit_order() =
- |" Return the value of System.Default_Bit_Order if any ``with System``
+ |" Return the value of ``System.Default_Bit_Order`` if any ``with System``
|" clause is found, null otherwise.
{
val w = (select first w@WithClause
@@ -581,8 +586,9 @@ fun default_bit_order() =
}
fun has_non_default_sso(decl) =
- |" Return true if ``decl`` has a Scalar_Storage_Order aspect whose value
- |" cannot be determined to be equal to System.Default_Storage_Order.
+ |" Return true if ``decl`` has a ``Scalar_Storage_Order`` aspect whose
+ |" value cannot be determined to be equal to
+ |" ``System.Default_Storage_Order``.
{
val aspect = decl.p_get_aspect("Scalar_Storage_Order");
@@ -599,8 +605,8 @@ fun has_non_default_sso(decl) =
}
selector component_types
- |" Return all the BaseTypeDecl corresponding to all fields
- |" of a given type, including their full views, base types and subtypes.
+ |" Return all the ``BaseTypeDecl``s corresponding to all fields of a given
+ |" type, including their full views, base types and subtypes.
| TypeDecl(f_type_def is d@RecordTypeDef) =>
skip *(from d select ComponentDecl)
| TypeDecl(f_type_def is DerivedTypeDef(f_record_extension is
diff --git a/lkql_checker/src/checker_app.adb b/lkql_checker/src/checker_app.adb
deleted file mode 100644
index 65e28ad1a..000000000
--- a/lkql_checker/src/checker_app.adb
+++ /dev/null
@@ -1,986 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Assertions; use Ada.Assertions;
-with Ada.Directories; use Ada.Directories;
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Text_IO;
-with Ada.Unchecked_Deallocation;
-with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO;
-
-with Langkit_Support.Diagnostics.Output;
-with Langkit_Support.Images; use Langkit_Support.Images;
-
-with Libadalang.Config_Pragmas;
-with Libadalang.Project_Provider; use Libadalang.Project_Provider;
-with Libadalang.Generic_API; use Libadalang.Generic_API;
-
-with Ada.Strings.Fixed; use Ada.Strings.Fixed;
-with Ada.Strings.Wide_Wide_Unbounded; use Ada.Strings.Wide_Wide_Unbounded;
-with Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash;
-with Ada.Containers.Hashed_Maps;
-with LKQL.Primitives; use LKQL.Primitives;
-with LKQL.Evaluation; use LKQL.Evaluation;
-
-with Langkit_Support.Diagnostics; use Langkit_Support.Diagnostics;
-with LKQL.Errors; use LKQL.Errors;
-with Liblkqllang.Analysis;
-
-with GNAT.OS_Lib;
-with GNAT.Traceback.Symbolic;
-
-with GNATCOLL.Terminal; use GNATCOLL.Terminal;
-with GNATCOLL.Utils;
-
-package body Checker_App is
-
- use Langkit_Support.Generic_API;
-
- type Lkql_Context_Array is array (Job_ID range <>) of Lkql_Context_Access;
- -- Array of Lkql_Contexts
-
- type Lkql_Context_Array_Access is access all Lkql_Context_Array;
- -- Access to array of contexts
-
- Lkql_Contexts : Lkql_Context_Array_Access := null;
- -- Global reference to an array of LKQL contexts. Each Job will get one
- -- context.
-
- function Get_Context (ID : Job_ID) return Lkql_Context_Access
- is (Lkql_Contexts (ID));
- -- Helper to get the context corresponding to a job ID
-
- procedure Process_Rules (Ctx : in out Lkql_Context);
- -- Process input rules: Put the rules that have been requested by the user
- -- in the ``Cached_Rules`` data structures.
-
- ------------------
- -- Process_Unit --
- ------------------
-
- procedure Process_Unit
- (Ctx : Lkql_Context;
- Unit : Analysis_Unit;
- Emit_Message :
- access procedure (Message : Unbounded_Text_Type;
- Unit : LK.Lk_Unit;
- Rule : Unbounded_Text_Type;
- Kind : Message_Kinds;
- Sloc_Range : Source_Location_Range) := null)
- is
- Lk_Unit : constant LK.Lk_Unit := To_Generic_Unit (Unit);
-
- Ada_Node_T : constant LKI.Type_Ref :=
- Ctx.Eval_Ctx.Get_Name_Map.Lookup_Type
- (Ctx.Eval_Ctx.Symbol ("AdaNode"));
-
- Generic_Instantiation : constant LKI.Type_Ref :=
- Ctx.Eval_Ctx.Get_Name_Map.Lookup_Type
- (Ctx.Eval_Ctx.Symbol ("GenericInstantiation"));
-
- Basic_Decl : constant LKI.Type_Ref :=
- Ctx.Eval_Ctx.Get_Name_Map.Lookup_Type
- (Ctx.Eval_Ctx.Symbol ("BasicDecl"));
-
- Body_Stub : constant LKI.Type_Ref :=
- Ctx.Eval_Ctx.Get_Name_Map.Lookup_Type
- (Ctx.Eval_Ctx.Symbol ("BodyStub"));
-
- Designated_Generic_Decl : constant LKI.Struct_Member_Ref :=
- Ctx.Eval_Ctx.Get_Name_Map.Lookup_Struct_Member
- (Generic_Instantiation,
- Ctx.Eval_Ctx.Symbol ("p_designated_generic_decl"));
-
- Body_Part_For_Decl : constant LKI.Struct_Member_Ref :=
- Ctx.Eval_Ctx.Get_Name_Map.Lookup_Struct_Member
- (Basic_Decl,
- Ctx.Eval_Ctx.Symbol ("p_body_part_for_decl"));
-
- Next_Part_For_Decl : constant LKI.Struct_Member_Ref :=
- Ctx.Eval_Ctx.Get_Name_Map.Lookup_Struct_Member
- (Basic_Decl,
- Ctx.Eval_Ctx.Symbol ("p_next_part_for_decl"));
-
- Defining_Name : constant LKI.Struct_Member_Ref :=
- Ctx.Eval_Ctx.Get_Name_Map.Lookup_Struct_Member
- (Basic_Decl,
- Ctx.Eval_Ctx.Symbol ("p_defining_name"));
-
- Generic_Instantiations : constant LKI.Struct_Member_Ref :=
- Ctx.Eval_Ctx.Get_Name_Map.Lookup_Struct_Member
- (Ada_Node_T,
- Ctx.Eval_Ctx.Symbol ("p_generic_instantiations"));
-
- procedure Handle_Error
- (Rule : Rule_Command;
- Node : LK.Lk_Node;
- Exc : Exception_Occurrence;
- Severe : Boolean);
- -- Factorize the error handling code, so that it can be shared amongst
- -- the two kinds of checkers, node checkers and unit checkers.
- -- "Severe" flags severe errors that should not be hidden.
-
- function Strip_LF (S : String) return String is
- (if S (S'Last) = ASCII.LF then S (S'First .. S'Last - 1) else S);
- -- Remove trailing LF if any
-
- ------------------
- -- Handle_Error --
- ------------------
-
- procedure Handle_Error
- (Rule : Rule_Command;
- Node : LK.Lk_Node;
- Exc : Exception_Occurrence;
- Severe : Boolean)
- is
- begin
- declare
- Data : constant Error_Data := Ctx.Eval_Ctx.Last_Error;
- Lkql_Node : constant LKQL.L.Lkql_Node := Data.AST_Node;
- Diag : constant Diagnostic :=
- (Sloc_Range => Lkql_Node.Sloc_Range,
- Message => Data.Short_Message);
- E : Exception_Occurrence_Access :=
- Data.Property_Error_Info;
-
- procedure Unchecked_Free is new Ada.Unchecked_Deallocation
- (Exception_Occurrence, Exception_Occurrence_Access);
-
- procedure Internal_Error (Msg : Wide_Wide_String);
- -- Call Emit_Message to store an internal error message
-
- procedure Internal_Error (Msg : Wide_Wide_String) is
- Exception_Msg : constant String :=
- Strip_LF
- (Exception_Information (if E /= null then E.all else Exc));
- Type_Error : constant Boolean :=
- Index (Exception_Msg, "Type error:") /= 0;
-
- begin
- Emit_Message
- (To_Unbounded_Text
- (Msg & " at " &
- To_Text
- (Simple_Name (Lkql_Node.Unit.Get_Filename)) & ":" &
- To_Text
- (Stripped_Image
- (Integer (Lkql_Node.Sloc_Range.Start_Line))) &
- ":" &
- To_Text
- (Stripped_Image
- (Integer (Lkql_Node.Sloc_Range.Start_Column))) &
- ": " &
- To_Text (Exception_Msg)),
- Node.Unit, Rule.Name,
- (if Severe or else Type_Error
- then Severe_Internal_Error else Internal_Error),
- Node.Sloc_Range);
- end Internal_Error;
-
- begin
- case Property_Error_Recovery is
- when Continue_And_Log =>
- if Emit_Message /= null then
- Internal_Error ("internal warning");
- else
- Eval_Trace.Trace ("Evaluating rule predicate failed");
- Eval_Trace.Trace ("rule => " & Image (To_Text (Rule.Name)));
- Eval_Trace.Trace ("ada node => " & Node.Image);
-
- if E /= null then
- Eval_Trace.Trace (Exception_Information (E.all));
- Eval_Trace.Trace
- (GNAT.Traceback.Symbolic.Symbolic_Traceback
- (E.all));
- end if;
- end if;
-
- when Continue_And_Warn =>
- if Emit_Message /= null then
- Internal_Error ("internal error");
- else
- Put ("ERROR! evaluating rule predicate failed");
-
- if E /= null then
- Put_Line (" in a property call");
- end if;
-
- Put_Line (" on node => " & To_Text (Node.Image));
-
- Langkit_Support.Diagnostics.Output.Print_Diagnostic
- (Self => Diag,
- Buffer => Lkql_Node.Unit,
- Path => Lkql_Node.Unit.Get_Filename,
- Output_File => Ada.Text_IO.Standard_Error);
-
- if E /= null then
- Ada.Text_IO.Put_Line
- (Ada.Text_IO.Standard_Error,
- Exception_Information (E.all));
- Ada.Text_IO.Put_Line
- (Ada.Text_IO.Standard_Error,
- GNAT.Traceback.Symbolic.Symbolic_Traceback (E.all));
- end if;
- end if;
-
- when Raise_Error =>
- Reraise_Occurrence (Exc);
- end case;
-
- -- If we didn't raise and there is exception information
- -- linked to a wrapped property error, free it.
-
- Unchecked_Free (E);
- end;
- end Handle_Error;
-
- In_Generic_Instantiation : Boolean := False;
- -- Track whether we are in the traversal of a generic instantiation, to
- -- only call rules that want to follow generic instantiations.
-
- function Visit (Node : LK.Lk_Node) return LK.Visit_Status;
-
- -----------
- -- Visit --
- -----------
-
- function Visit (Node : LK.Lk_Node) return LK.Visit_Status is
- In_Generic_Instantiation_Old_Val : Boolean;
- begin
- if Ctx.Traverse_Instantiations then
- if LKI.Type_Matches
- (LKI.From_Node
- (LK.Language (Node), Node), Generic_Instantiation)
- then
- -- Save old value, and set In_Generic_Instantiation to true
- In_Generic_Instantiation_Old_Val := In_Generic_Instantiation;
- In_Generic_Instantiation := True;
-
- declare
- Gen_Decl : constant LK.Lk_Node := LKI.As_Node
- (LKI.Eval_Node_Member
- (Node, Designated_Generic_Decl));
-
- Gen_Body : constant LK.Lk_Node := LKI.As_Node
- (LKI.Eval_Node_Member
- (Gen_Decl,
- Body_Part_For_Decl,
- [LKI.From_Bool (Ada_Lang_Id, False)]));
- begin
- LK.Traverse (Gen_Decl, Visit'Access);
-
- -- Also traverse the body of the generic, if there is one
- if not Gen_Body.Is_Null then
- LK.Traverse (Gen_Body, Visit'Access);
- end if;
- end;
-
- -- Restore old value
- In_Generic_Instantiation := In_Generic_Instantiation_Old_Val;
-
- -- Also traverse stub bodies if already part of an instantiation
-
- elsif In_Generic_Instantiation
- and then LKI.Type_Matches
- (LKI.From_Node (LK.Language (Node), Node), Body_Stub)
- then
- declare
- Separate_Body : constant LK.Lk_Node := LKI.As_Node
- (LKI.Eval_Node_Member
- (Node,
- Next_Part_For_Decl,
- [LKI.From_Bool (Ada_Lang_Id, False)]));
- begin
- LK.Traverse (Separate_Body, Visit'Access);
- end;
- end if;
- end if;
-
- Mark (Ctx.Eval_Ctx.Pools);
-
- Ctx.Eval_Ctx.Add_Binding
- ("node", To_Primitive (Node, Ctx.Eval_Ctx.Pool));
-
- for Rule of Ctx.Cached_Rules (LKI.To_Index (LKI.Type_Of (Node))) loop
-
- -- Skip unit check rules
-
- if Rule.Is_Unit_Check then
- goto Next;
- end if;
-
- -- If we are in a generic instantiation and the rule doesn't care
- -- about them, bail out.
-
- if In_Generic_Instantiation and then not Rule.Follow_Instantiations
- then
- goto Next;
- end if;
-
- declare
- Result_Node : LK.Lk_Node;
- begin
- Rule.Eval_Ctx.Add_Binding
- ("node", To_Primitive (Node, Rule.Eval_Ctx.Pool));
-
- -- The check is a "bool check", ie. a check that returns a
- -- boolean. Eval the call to the check function
-
- if Bool_Val
- (Eval (Rule.Eval_Ctx, Rule.Function_Expr, Kind_Bool))
- then
-
- -- The result node is the current node
-
- Result_Node := Node;
-
- -- If the result node is a decl, grab its defining
- -- identifier, so that the diagnostic spans only one line.
- -- TODO: this logic could somehow be hoisted directly into
- -- langkit diagnostics.
-
- if LKI.Type_Matches
- (LKI.From_Node (Result_Node.Language, Result_Node),
- Basic_Decl)
- then
- declare
- DN : constant LK.Lk_Node := LKI.As_Node
- (LKI.Eval_Node_Member (Result_Node, Defining_Name));
- begin
- -- Some basic decls don't have a defining name,
- -- e.g. Anonymous_Type_Decl.
- if not DN.Is_Null then
- Result_Node := DN;
- end if;
- end;
- end if;
-
- if Emit_Message /= null then
- if not Rule.Follow_Instantiations then
- Emit_Message
- (Rule.Message, Result_Node.Unit, Rule.Name,
- Rule_Violation, Result_Node.Sloc_Range);
- else
- declare
- Insts : constant LKI.Value_Ref_Array :=
- LKI.As_Array
- (LKI.Eval_Node_Member
- (Result_Node, Generic_Instantiations));
-
- Msg : Unbounded_Text_Type := Rule.Message;
-
- begin
- -- For generic instantiations, append
- -- [instance at file:line [file:line [...]]]
-
- for J in Insts'Range loop
- declare
- N : constant LK.Lk_Node :=
- LKI.As_Node (Insts (J));
- begin
- if J = Insts'First then
- Append (Msg, " [instance at ");
- else
- Append (Msg, " [");
- end if;
-
- Append (Msg,
- To_Text (Simple_Name
- (N.Unit.Filename)));
- Append (Msg, ":");
- Append
- (Msg,
- To_Text
- (Stripped_Image
- (Integer (N.Sloc_Range.Start_Line))));
- end;
- end loop;
-
- for J in Insts'Range loop
- Append (Msg, "]");
- end loop;
-
- Emit_Message
- (Msg, Result_Node.Unit, Rule.Name,
- Rule_Violation, Result_Node.Sloc_Range);
- end;
- end if;
- else
- declare
- Diag : constant Eval_Diagnostic := Eval_Diagnostic'
- (Diagnostic'
- (Result_Node.Sloc_Range,
- To_Unbounded_Text (To_Text (Rule.Message))),
- Result_Node.Unit);
- begin
- Output.Print_Diagnostic
- (Diag.Diag,
- Diag.Unit,
- Simple_Name (Diag.Unit.Filename),
- Style => Output.Diagnostic_Style'
- (Label => To_Unbounded_Text ("rule violation"),
- Color => Yellow));
- end;
- end if;
- end if;
-
- exception
- when E : LKQL.Errors.Stop_Evaluation_Error =>
- Handle_Error (Rule, Node, E, Severe => False);
- when E : others =>
- if Emit_Message /= null then
- Emit_Message
- (To_Unbounded_Wide_Wide_String
- ("internal error on rule " &
- To_Text (Rule.Name) & ": " &
- To_Text (Strip_LF (Exception_Information (E)))),
- Node.Unit, Rule.Name,
- Severe_Internal_Error, Node.Sloc_Range);
-
- else
- Put_Line
- (Standard_Error,
- "Evaluating query predicate failed unrecoverably");
- Put_Line
- (Standard_Error, "rule => " & To_Text (Rule.Name));
- Put_Line
- (Standard_Error, "ada node => " & To_Text (Node.Image));
- Ada.Text_IO.Put_Line (Exception_Information (E));
- Ada.Text_IO.Put_Line
- (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
- end if;
- end;
-
- <>
- end loop;
-
- Release (Ctx.Eval_Ctx.Pools);
- return LK.Into;
- end Visit;
-
- List : Primitive_List_Access;
-
- begin
- -- Run node checks
- LK.Traverse (Lk_Unit.Root, Visit'Access);
-
- -- Run unit checks
- for Rule of Ctx.Cached_Rules (LKI.To_Index (LKI.Type_Of (Lk_Unit.Root)))
- loop
- begin
- Mark (Rule.Eval_Ctx.Pools);
-
- if Rule.Is_Unit_Check then
- declare
- Result : Primitive;
- begin
- Rule.Eval_Ctx.Add_Binding
- ("unit", To_Primitive (Lk_Unit, Rule.Eval_Ctx.Pool));
-
- Result := Eval (Rule.Eval_Ctx, Rule.Code);
-
- if Result.Kind = Kind_Iterator then
- Consume (Result);
- List := Result.Iter_Cache;
- else
- Check_Kind
- (Rule.Eval_Ctx, Rule.Lkql_Root, Kind_List, Result);
-
- List := Result.List_Val;
- end if;
-
- for El of List.Elements loop
- Check_Kind
- (Rule.Eval_Ctx, Rule.Lkql_Root, Kind_Object, El);
-
- declare
- Loc_Val : constant Primitive :=
- Extract_Value (El, "loc", Rule.Eval_Ctx, No_Kind,
- Location => Rule.Lkql_Root);
-
- Loc : Source_Location_Range;
-
- Message : constant Unbounded_Text_Type :=
- To_Unbounded_Text
- (Extract_Value
- (El, "message", Rule.Eval_Ctx, Kind_Str,
- Location => Rule.Lkql_Root).Str_Val.all);
-
- Diag : Diagnostic;
- Loc_Unit : LK.Lk_Unit;
-
- begin
- -- Loc can be either a token value or a node value. In
- -- both cases we'll extract the source location and
- -- the unit from it.
-
- if Loc_Val.Kind = Kind_Node then
- declare
- Node : constant LK.Lk_Node := Loc_Val.Node_Val;
- begin
- Loc := Node.Sloc_Range;
- Loc_Unit := Node.Unit;
- end;
-
- elsif Loc_Val.Kind = Kind_Token then
- declare
- Token : constant LK.Lk_Token :=
- Loc_Val.Token_Val;
- begin
- Loc := Token.Sloc_Range;
- Loc_Unit := Token.Unit;
- end;
- end if;
-
- if Emit_Message /= null then
- if Loc_Val.Kind = Kind_Node then
- declare
- Insts : constant LKI.Value_Ref_Array :=
- LKI.As_Array
- (LKI.Eval_Node_Member
- (Loc_Val.Node_Val,
- Generic_Instantiations));
- Msg : Unbounded_Text_Type := Message;
-
- begin
- -- For generic instantiations, append
- -- [instance at file:line [file:line [...]]]
-
- for J in Insts'Range loop
- declare
- N : constant LK.Lk_Node :=
- LKI.As_Node (Insts (J));
- begin
- if J = Insts'First then
- Append (Msg, " [instance at ");
- else
- Append (Msg, " [");
- end if;
-
- Append (Msg,
- To_Text (Simple_Name
- (N.Unit.Filename)));
- Append (Msg, ":");
- Append
- (Msg,
- To_Text
- (Stripped_Image
- (Integer
- (N.Sloc_Range.Start_Line))));
- end;
- end loop;
-
- for J in Insts'Range loop
- Append (Msg, "]");
- end loop;
-
- Emit_Message
- (Msg, Loc_Unit, Rule.Name,
- Rule_Violation, Loc);
- end;
- else
- Emit_Message
- (Message, Loc_Unit, Rule.Name,
- Rule_Violation, Loc);
- end if;
- else
- Diag := (Message => Message, Sloc_Range => Loc);
-
- Output.Print_Diagnostic
- (Self => Diag,
- Buffer => Loc_Unit,
- Path =>
- Simple_Name (Loc_Unit.Filename),
- Style => Output.Diagnostic_Style'
- (Label => To_Unbounded_Text ("rule violation"),
- Color => Yellow));
- end if;
- end;
- end loop;
-
- exception
- when E : LKQL.Errors.Stop_Evaluation_Error =>
- Handle_Error (Rule, Lk_Unit.Root, E, Severe => False);
- end;
- end if;
-
- Release (Rule.Eval_Ctx.Pools);
- exception
- when E : LKQL.Errors.Stop_Evaluation_Error | Assertion_Error =>
- Release (Rule.Eval_Ctx.Pools);
- Handle_Error (Rule, Lk_Unit.Root, E, Severe => True);
- end;
- end loop;
- end Process_Unit;
-
- procedure Process_Unit (Context : App_Job_Context; Unit : Analysis_Unit) is
- procedure No_Message
- (Message : Unbounded_Text_Type;
- Unit : LK.Lk_Unit;
- Rule : Unbounded_Text_Type;
- Kind : Message_Kinds;
- Sloc_Range : Source_Location_Range) is null;
-
- procedure Emit_Message
- (Message : Unbounded_Text_Type;
- Unit : LK.Lk_Unit;
- Rule : Unbounded_Text_Type;
- Kind : Message_Kinds;
- Sloc_Range : Source_Location_Range);
- -- Callback to emit a gnatcheck-like message on stdout
-
- ------------------
- -- Emit_Message --
- ------------------
-
- procedure Emit_Message
- (Message : Unbounded_Text_Type;
- Unit : LK.Lk_Unit;
- Rule : Unbounded_Text_Type;
- Kind : Message_Kinds;
- Sloc_Range : Source_Location_Range)
- is
- pragma Unreferenced (Rule, Kind);
- begin
- Ada.Text_IO.Put
- (Simple_Name (Unit.Filename) & ":"
- & Stripped_Image
- (Integer (Sloc_Range.Start_Line))
- & ":"
- & Stripped_Image
- (Integer (Sloc_Range.Start_Column))
- & ": ");
- Put_Line (To_Text (Message));
- end Emit_Message;
-
- begin
- Process_Unit
- (Get_Context (Context.ID).all, Unit,
- (if Args.Output_Style.Get = GNATcheck
- then Emit_Message'Access
- elsif Args.Output_Style.Get = Silent
- then No_Message'Access
- else null));
- end Process_Unit;
-
- package Rules_Args_Maps is new Ada.Containers.Hashed_Maps
- (Key_Type => Unbounded_Text_Type,
- Element_Type => Rule_Argument_Vectors.Vector,
- Hash => Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash,
- Equivalent_Keys => Ada.Strings.Wide_Wide_Unbounded."=",
- "=" => Rule_Argument_Vectors."=");
-
- -----------------
- -- Append_Rule --
- -----------------
-
- procedure Append_Rule (Ctx : in out Lkql_Context; Rule : Rule_Command) is
- use Liblkqllang.Analysis;
- begin
- if Rule.Kind_Pattern /= No_Node_Kind_Pattern then
- declare
- Type_Ref : constant LKI.Type_Ref :=
- Ctx.Eval_Ctx.Get_Name_Map.Lookup_Type
- (Ctx.Eval_Ctx.Symbol (Rule.Kind_Pattern.F_Kind_Name.Text));
-
- Type_Id : constant LKI.Type_Index := LKI.To_Index (Type_Ref);
- begin
- for I in Type_Id .. LKI.Last_Derived_Type (Type_Ref) loop
- Ctx.Cached_Rules (I).Append (Rule);
- end loop;
- end;
- else
- for I in Ctx.Cached_Rules'Range loop
- Ctx.Cached_Rules (I).Append (Rule);
- end loop;
- end if;
-
- -- If we have one rule that needs to follow instantiations, then set
- -- the traversal to traverse them.
-
- if Rule.Follow_Instantiations then
- Ctx.Traverse_Instantiations := True;
- end if;
- end Append_Rule;
-
- -----------
- -- Rules --
- -----------
-
- procedure Process_Rules (Ctx : in out Lkql_Context) is
-
- Explicit_Rules_Names : constant Args.Rules.Result_Array :=
- Args.Rules.Get;
-
- Additional_Rules_Dirs : Path_Vector;
-
- Rules_Args_Map : Rules_Args_Maps.Map;
- -- Map from argument names to argument values.
-
- function Add_Rule_Dir (Path : String) return Boolean;
- -- Add the given path to the list of directories in which to look for
- -- LKQL rules.
-
- function Add_Rule_Dir (Path : String) return Boolean is
- begin
- Additional_Rules_Dirs.Append (Path);
- return True;
- end Add_Rule_Dir;
-
- use Rule_Vectors;
- begin
- if not Ctx.All_Rules.Is_Empty then
- return;
- end if;
-
- GNATCOLL.Utils.Split
- (To_String (Args.Rules_Dirs.Get),
- GNAT.OS_Lib.Path_Separator & "",
- Add_Rule_Dir'Access);
-
- Ctx.All_Rules := All_Rules (Ctx.Eval_Ctx, Additional_Rules_Dirs);
-
- -- Compute the map of argument names to values.
-
- for Rule_Arg of Args.Rules_Args.Get loop
- declare
- Dummy : Boolean;
- C : Rules_Args_Maps.Cursor;
- begin
- Rules_Args_Map.Insert
- (Rule_Arg.Rule_Name,
- Rule_Argument_Vectors.Empty_Vector,
- C, Dummy);
-
- Rules_Args_Map.Reference (C).Append (Rule_Arg.Arg);
- end;
- end loop;
-
- -- Then, process potential arguments for those rules
-
- for Rule of Ctx.All_Rules loop
- declare
- Rule_Name : constant Unbounded_Text_Type := Rule.Name;
- C : constant Rules_Args_Maps.Cursor
- := Rules_Args_Map.Find (Rule_Name);
- begin
- -- Modify the rule command in place, by appending an argument to
- -- the Rule_Command's arg vector.
-
- if Rule.Is_Unit_Check then
- Rule.Rule_Args.Append
- (Rule_Argument'(Name => To_Unbounded_Text ("unit"),
- Value => To_Unbounded_Text ("unit")));
- else
- Rule.Rule_Args.Append
- (Rule_Argument'(Name => To_Unbounded_Text ("node"),
- Value => To_Unbounded_Text ("node")));
- end if;
-
- if Rules_Args_Maps.Has_Element (C) then
- for Arg of Rules_Args_Map.Reference (C) loop
- Rule.Rule_Args.Append (Arg);
- end loop;
- end if;
- end;
-
- -- Call prepare *after* processing the arguments, since it needs the
- -- arguments processed.
- Rule.Prepare;
- end loop;
-
- -- First, process the set of rules that has to be ran.
-
- if Explicit_Rules_Names'Length = 0 then
- -- No rules passed by the user: return all rules
- for Rule of Ctx.All_Rules loop
- Append_Rule (Ctx, Rule);
- end loop;
-
- else
- -- Some rules passed by the user: only return the ones specified
- for Explicit_Rule_Name of Explicit_Rules_Names loop
- declare
- Found : Boolean := False;
- begin
- for R of Ctx.All_Rules loop
- if To_Lower (To_Text (To_String (Explicit_Rule_Name)))
- = To_Text (R.Name)
- then
- Append_Rule (Ctx, R);
- Found := True;
- end if;
- end loop;
- if not Found then
- raise Exit_App with "no such rule - "
- & To_String (Explicit_Rule_Name);
- end if;
- end;
- end loop;
- end if;
- end Process_Rules;
-
- procedure App_Setup
- (Context : App_Context; Jobs : App_Job_Context_Array)
- is
- pragma Unreferenced (Context);
- begin
- Lkql_Contexts := new Lkql_Context_Array (Jobs'Range);
- for I in Lkql_Contexts'Range loop
- Lkql_Contexts (I) := new Lkql_Context;
- end loop;
- end App_Setup;
-
- ---------------
- -- Job_Setup --
- ---------------
-
- procedure Job_Setup (Context : App_Job_Context) is
- Dummy : Primitive;
- Units : Unit_Vectors.Vector;
- Files : String_Vectors.Vector;
-
- begin
- declare
- Ctx : Lkql_Context_Access renames Get_Context (Context.ID);
- begin
-
- case Context.App_Ctx.Provider.Kind is
- when Project_File =>
- Files := Source_Files (Context.App_Ctx.Provider.Project.all);
-
- for F of Files loop
- Units.Append
- (Context.Analysis_Ctx.Get_From_File (To_String (F)));
- end loop;
-
- -- Setup the configuration pragma mapping by reading the
- -- configuration file given by the project.
- Libadalang.Config_Pragmas.Import_From_Project
- (Context.Analysis_Ctx, Context.App_Ctx.Provider.Project.all);
-
- when Default =>
- for F of App.Args.Files.Get loop
- Units.Append
- (Context.Analysis_Ctx.Get_From_File (To_String (F)));
- end loop;
-
- when others =>
- -- ??? Should we worry about this case and fill Units
- null;
- end case;
-
- declare
- Roots : LK.Lk_Node_Array (Units.First_Index .. Units.Last_Index);
- begin
-
- for I in Roots'Range loop
- Roots (I) :=
- To_Generic_Unit (Units (I)).Root;
- end loop;
-
- Ctx.Eval_Ctx := Make_Eval_Context
- (Roots, Ada_Lang_Id);
- Ctx.Analysis_Ctx := Context.Analysis_Ctx;
-
- -- Initialize the cached rules array, with an array that goes from
- -- the index of the first root node type, to the index of the last
- -- derived type. This array will have too many slots since is has
- -- slots for abstract types, but we don't really care.
- declare
- Root_Node_Type : LKI.Type_Ref
- renames LKI.Root_Node_Type (Ada_Lang_Id);
- subtype Rules_By_Kind_Array_Subt is
- Rules_By_Kind_Array
- (LKI.To_Index (Root_Node_Type)
- .. LKI.Last_Derived_Type (Root_Node_Type));
-
- begin
- Ctx.Cached_Rules := new Rules_By_Kind_Array_Subt;
- end;
-
- Process_Rules (Get_Context (Context.ID).all);
-
- for Rule of Ctx.All_Rules loop
- -- Eval the rule's code (which should contain only
- -- definitions). TODO this should be encapsulated.
- begin
- Dummy := Eval (Rule.Eval_Ctx, Rule.Lkql_Root);
- exception
- when others =>
- Put ("internal error loading rule ");
- Put (To_Text (Rule.Name));
- Put_Line (":");
- raise;
- end;
- end loop;
-
- -- Set property error recovery with the value of the command line
- -- flag.
- LKQL.Errors.Property_Error_Recovery
- := Args.Property_Error_Recovery.Get;
- end;
- end;
- end Job_Setup;
-
- procedure Job_Post_Process (Context : App_Job_Context) is
- Ctx : Lkql_Context renames Get_Context (Context.ID).all;
- begin
- Finalize_Rules (Ctx.Eval_Ctx);
- Free_Eval_Context (Ctx.Eval_Ctx);
- end Job_Post_Process;
-
- package body Args is
-
- -------------
- -- Convert --
- -------------
-
- function Convert (Raw_Arg : String) return Qualified_Rule_Argument is
- First_Dot : constant Natural :=
- Index (Raw_Arg, Pattern => ".");
- First_Equal : constant Natural :=
- Index (Raw_Arg, Pattern => "=", From => First_Dot);
- Ret : Qualified_Rule_Argument;
- begin
- if First_Dot = 0 or First_Equal = 0 then
- raise Opt_Parse_Error
- with "Wrong format for rule argument: " & Raw_Arg;
- end if;
- Ret.Rule_Name :=
- To_Unbounded_Text
- (To_Lower (To_Text (Raw_Arg (Raw_Arg'First .. First_Dot - 1))));
- Ret.Arg.Name :=
- To_Unbounded_Text
- (To_Text (Raw_Arg (First_Dot + 1 .. First_Equal - 1)));
- Ret.Arg.Value :=
- To_Unbounded_Text
- (To_Text (Raw_Arg (First_Equal + 1 .. Raw_Arg'Last)));
-
- return Ret;
- end Convert;
-
- end Args;
-
-end Checker_App;
diff --git a/lkql_checker/src/checker_app.ads b/lkql_checker/src/checker_app.ads
index c3cd63214..a465bd1eb 100644
--- a/lkql_checker/src/checker_app.ads
+++ b/lkql_checker/src/checker_app.ads
@@ -21,33 +21,19 @@
-- . --
------------------------------------------------------------------------------
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-
-with GNATCOLL.Opt_Parse;
-
-with Langkit_Support.Slocs; use Langkit_Support.Slocs;
-
with Libadalang.Analysis; use Libadalang.Analysis;
-with Libadalang.Helpers; use Libadalang.Helpers;
-with LKQL.Errors;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with Rule_Commands; use Rule_Commands;
with Rules_Factory; use Rules_Factory;
-with Langkit_Support.Text; use Langkit_Support.Text;
with Langkit_Support.Generic_API.Analysis;
with Langkit_Support.Generic_API.Introspection;
+-- TODO: Factor into another package, check what is dead. See #190
package Checker_App is
package LK renames Langkit_Support.Generic_API.Analysis;
package LKI renames Langkit_Support.Generic_API.Introspection;
- Exit_App : exception;
- -- Exception raised by the app if it wants to exit with an error status and
- -- a message.
-
type Rules_By_Kind_Array
is array (LKI.Any_Type_Index range <>) of Rule_Vector;
@@ -55,7 +41,8 @@ package Checker_App is
type Lkql_Context is record
Analysis_Ctx : Analysis_Context;
- Eval_Ctx : Eval_Context;
+ LKQL_Analysis_Context : L.Analysis_Context;
+
Cached_Rules : Rules_By_Kind := null;
-- Data structure mapping node kinds to the checks that should be ran
-- when this node type is encountered.
@@ -72,16 +59,9 @@ package Checker_App is
-- Context giving access to all the "global" data structures for an LKQL
-- analysis.
- procedure Append_Rule (Ctx : in out Lkql_Context; Rule : Rule_Command);
- -- Append the given rule to ``Cached_Rules``.
-
type Lkql_Context_Access is access all Lkql_Context;
-- Access to an LKQL context
- procedure App_Setup
- (Context : App_Context; Jobs : App_Job_Context_Array);
- procedure Job_Setup (Context : App_Job_Context);
-
type Message_Kinds is
(Rule_Violation, Internal_Error, Severe_Internal_Error);
-- Rule_Violation: a rule is flagged
@@ -89,93 +69,4 @@ package Checker_App is
-- Severe_Internal_Error: a severe internal error occurred which should
-- not be hidden.
- procedure Process_Unit
- (Ctx : Lkql_Context;
- Unit : Analysis_Unit;
- Emit_Message :
- access procedure (Message : Unbounded_Text_Type;
- Unit : LK.Lk_Unit;
- Rule : Unbounded_Text_Type;
- Kind : Message_Kinds;
- Sloc_Range : Source_Location_Range) := null);
- -- Process one analysis unit.
- -- Call Emit_Message on each match, if non null.
-
- procedure Process_Unit
- (Context : App_Job_Context; Unit : Analysis_Unit);
- -- Process one analysis unit in a given context
-
- procedure Job_Post_Process
- (Context : App_Job_Context);
-
- package App is new Libadalang.Helpers.App
- (Name => "lkql-checker",
- Description => "LKQL based rule checker",
- Process_Unit => Process_Unit,
- App_Setup => App_Setup,
- Job_Setup => Job_Setup,
- Enable_Parallelism => True,
- Job_Post_Process => Job_Post_Process);
-
- package Args is
- use GNATCOLL.Opt_Parse;
-
- type Qualified_Rule_Argument is record
- Rule_Name : Unbounded_Text_Type;
- Arg : Rule_Argument;
- end record;
- -- Argument for a rule, including the rule name. Directly parsed from
- -- the command line.
-
- function Convert (Raw_Arg : String) return Qualified_Rule_Argument;
- -- Convert a string of the form "rule_name.arg_name=val" into a
- -- ``Qualified_Rule_Argument``.
-
- package Rules_Dirs is new Parse_Option
- (Parser => App.Args.Parser,
- Long => "--rules-dirs",
- Help => "List of directories from where rules will be"
- & "searched, separated by the OS path separator",
- Arg_Type => Unbounded_String,
- Default_Val => Null_Unbounded_String);
-
- package Rules is new Parse_Option_List
- (Parser => App.Args.Parser,
- Short => "-r",
- Long => "--rule",
- Help => "Rule to apply (if not passed, all rules are applied)",
- Accumulate => True,
- Arg_Type => Unbounded_String);
- -- We use an option rt. a positional arg because we cannot add anymore
- -- positional args to the App parser.
-
- package Rules_Args is new Parse_Option_List
- (Parser => App.Args.Parser,
- Short => "-a",
- Long => "--rule-arg",
- Help => "Argument to pass to a rule, with the syntax "
- & ". = ",
- Accumulate => True,
- Arg_Type => Qualified_Rule_Argument);
- -- We use an option rt. a positional arg because we cannot add anymore
- -- positional args to the App parser.
-
- package Property_Error_Recovery is new Parse_Enum_Option
- (Parser => App.Args.Parser,
- Short => "-pr",
- Long => "--property-error-recovery",
- Help =>
- "Which behavior to adopt when there is a property error"
- & "inside of a LKQL query",
- Arg_Type => LKQL.Errors.Property_Error_Recovery_Kind,
- Default_Val => LKQL.Errors.Continue_And_Warn);
-
- package Output_Style is new Parse_Enum_Option
- (Parser => App.Args.Parser,
- Long => "--output-style",
- Help => "Output style for the diagnostic messages",
- Arg_Type => Output_Style,
- Default_Val => Default);
- end Args;
-
end Checker_App;
diff --git a/lkql_checker/src/exec.adb b/lkql_checker/src/exec.adb
deleted file mode 100644
index 6576cab9f..000000000
--- a/lkql_checker/src/exec.adb
+++ /dev/null
@@ -1,67 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Partial_AST_Nodes;
-with LKQL.Evaluation; use LKQL.Evaluation;
-with LKQL.Unit_Utils; use LKQL.Unit_Utils;
-
-with Libadalang.Analysis; use Libadalang.Analysis;
-with Ada_AST_Nodes; use Ada_AST_Nodes;
-
-package body Exec is
-
- ---------------
- -- Lkql_Eval --
- ---------------
-
- function Lkql_Eval
- (Context : Eval_Context;
- Lkql_Script : String;
- Lkql_Context : L.Analysis_Context :=
- L.No_Analysis_Context;
- Expected_Kind : Base_Primitive_Kind := No_Kind) return Primitive
- is
- begin
- return Eval
- (Context,
- Make_Lkql_Unit_From_Code (Lkql_Context, Lkql_Script).Root,
- Expected_Kind);
- end Lkql_Eval;
-
- ---------------
- -- Lkql_Eval --
- ---------------
-
- function Lkql_Eval
- (Lkql_Script : String;
- Lkql_Context : L.Analysis_Context :=
- L.No_Analysis_Context) return Primitive
- is
- Ctx : constant Eval_Context := Make_Eval_Context
- (LKQL.Partial_AST_Nodes.Empty_Ast_Node_Array,
- Make_Ada_AST_Node (No_Ada_Node));
- begin
- return Lkql_Eval (Ctx, Lkql_Script, Lkql_Context);
- end Lkql_Eval;
-
-end Exec;
diff --git a/lkql_checker/src/exec.ads b/lkql_checker/src/exec.ads
deleted file mode 100644
index c8f9b9700..000000000
--- a/lkql_checker/src/exec.ads
+++ /dev/null
@@ -1,46 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with LKQL; use LKQL;
-with LKQL.Primitives; use LKQL.Primitives;
-
-package Exec is
-
- function Lkql_Eval
- (Context : Eval_Context;
- Lkql_Script : String;
- Lkql_Context : L.Analysis_Context :=
- L.No_Analysis_Context;
- Expected_Kind : Base_Primitive_Kind := No_Kind) return Primitive;
- -- Evaluate the script in the given context and display the error
- -- messages, if any.
-
- function Lkql_Eval
- (Lkql_Script : String;
- Lkql_Context : L.Analysis_Context :=
- L.No_Analysis_Context) return Primitive;
- -- Evaluate the script in the given context and display the error
- -- messages, if any.
-
-end Exec;
diff --git a/lkql_checker/lalcheck/gnatcheck-compiler.adb b/lkql_checker/src/gnatcheck-compiler.adb
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-compiler.adb
rename to lkql_checker/src/gnatcheck-compiler.adb
diff --git a/lkql_checker/lalcheck/gnatcheck-compiler.ads b/lkql_checker/src/gnatcheck-compiler.ads
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-compiler.ads
rename to lkql_checker/src/gnatcheck-compiler.ads
diff --git a/lkql_checker/lalcheck/gnatcheck-diagnoses.adb b/lkql_checker/src/gnatcheck-diagnoses.adb
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-diagnoses.adb
rename to lkql_checker/src/gnatcheck-diagnoses.adb
diff --git a/lkql_checker/lalcheck/gnatcheck-diagnoses.ads b/lkql_checker/src/gnatcheck-diagnoses.ads
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-diagnoses.ads
rename to lkql_checker/src/gnatcheck-diagnoses.ads
diff --git a/lkql_checker/lalcheck/gnatcheck-ids.ads b/lkql_checker/src/gnatcheck-ids.ads
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-ids.ads
rename to lkql_checker/src/gnatcheck-ids.ads
diff --git a/lkql_checker/lalcheck/gnatcheck-options.ads b/lkql_checker/src/gnatcheck-options.ads
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-options.ads
rename to lkql_checker/src/gnatcheck-options.ads
diff --git a/lkql_checker/lalcheck/gnatcheck-output.adb b/lkql_checker/src/gnatcheck-output.adb
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-output.adb
rename to lkql_checker/src/gnatcheck-output.adb
diff --git a/lkql_checker/lalcheck/gnatcheck-output.ads b/lkql_checker/src/gnatcheck-output.ads
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-output.ads
rename to lkql_checker/src/gnatcheck-output.ads
diff --git a/lkql_checker/lalcheck/gnatcheck-projects-aggregate.adb b/lkql_checker/src/gnatcheck-projects-aggregate.adb
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-projects-aggregate.adb
rename to lkql_checker/src/gnatcheck-projects-aggregate.adb
diff --git a/lkql_checker/lalcheck/gnatcheck-projects-aggregate.ads b/lkql_checker/src/gnatcheck-projects-aggregate.ads
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-projects-aggregate.ads
rename to lkql_checker/src/gnatcheck-projects-aggregate.ads
diff --git a/lkql_checker/lalcheck/gnatcheck-projects.adb b/lkql_checker/src/gnatcheck-projects.adb
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-projects.adb
rename to lkql_checker/src/gnatcheck-projects.adb
diff --git a/lkql_checker/lalcheck/gnatcheck-projects.ads b/lkql_checker/src/gnatcheck-projects.ads
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-projects.ads
rename to lkql_checker/src/gnatcheck-projects.ads
diff --git a/lkql_checker/lalcheck/gnatcheck-rules-rule_table.adb b/lkql_checker/src/gnatcheck-rules-rule_table.adb
similarity index 96%
rename from lkql_checker/lalcheck/gnatcheck-rules-rule_table.adb
rename to lkql_checker/src/gnatcheck-rules-rule_table.adb
index 9b68f3f0b..093e19e23 100644
--- a/lkql_checker/lalcheck/gnatcheck-rules-rule_table.adb
+++ b/lkql_checker/src/gnatcheck-rules-rule_table.adb
@@ -24,7 +24,6 @@ with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
-with Ada.Wide_Wide_Text_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
@@ -40,8 +39,6 @@ with Rule_Commands; use Rule_Commands;
with Rules_Factory; use Rules_Factory;
with Ada.Strings.Wide_Wide_Unbounded; use Ada.Strings.Wide_Wide_Unbounded;
-with LKQL.Primitives; use LKQL.Primitives;
-with LKQL.Evaluation; use LKQL.Evaluation;
with Langkit_Support.Text; use Langkit_Support.Text;
@@ -1335,7 +1332,8 @@ package body Gnatcheck.Rules.Rule_Table is
end if;
Ctx.All_Rules :=
- Rules_Factory.All_Rules (Ctx.Eval_Ctx, Additional_Rules_Dirs);
+ Rules_Factory.All_Rules
+ (Ctx.LKQL_Analysis_Context, Additional_Rules_Dirs);
for R of Ctx.All_Rules loop
declare
@@ -1415,7 +1413,6 @@ package body Gnatcheck.Rules.Rule_Table is
Rule.Parameters := R.Parameters;
Rule.Remediation_Level := R.Remediation_Level;
Rule.Allows_Parametrized_Exemption := R.Parametric_Exemption;
- Rule.Follow_Instantiations := R.Follow_Instantiations;
Rule.Impact := R.Impact;
Rule.Target := R.Target;
All_Rules.Append (Rule);
@@ -1429,10 +1426,6 @@ package body Gnatcheck.Rules.Rule_Table is
procedure Process_Requested_Rules (Ctx : in out Lkql_Context) is
- Dummy : Primitive;
-
- -- Start of processing for Process_Requested_Rules
-
begin
-- Process potential arguments for rules
@@ -1466,49 +1459,8 @@ package body Gnatcheck.Rules.Rule_Table is
end if;
end loop;
end;
-
- -- Call prepare *after* processing the arguments, since it needs the
- -- arguments processed.
-
- Rule.Prepare;
end loop;
- for Rule in All_Rules.First .. All_Rules.Last loop
- if Is_Enabled (All_Rules.Table (Rule).all) then
- declare
- Found : Boolean := False;
- begin
- for R of Ctx.All_Rules loop
- if To_Text (All_Rules.Table (Rule).Name.all)
- = To_Text (R.Name)
- then
- Append_Rule (Ctx, R);
- Found := True;
- exit;
- end if;
- end loop;
-
- if not Found then
- raise Exit_App
- with "no such rule - " & All_Rules.Table (Rule).Name.all;
- end if;
- end;
- end if;
- end loop;
-
- for Rule of Ctx.All_Rules loop
- -- Eval the rule's code (which should contain only definitions). TODO
- -- this should be encapsulated.
- begin
- Dummy := Eval (Rule.Eval_Ctx, Rule.Lkql_Root);
- exception
- when others =>
- Put ("internal error loading rule ");
- Ada.Wide_Wide_Text_IO.Put (To_Wide_Wide_String (Rule.Name));
- Put_Line (":");
- raise;
- end;
- end loop;
end Process_Requested_Rules;
end Gnatcheck.Rules.Rule_Table;
diff --git a/lkql_checker/lalcheck/gnatcheck-rules-rule_table.ads b/lkql_checker/src/gnatcheck-rules-rule_table.ads
similarity index 99%
rename from lkql_checker/lalcheck/gnatcheck-rules-rule_table.ads
rename to lkql_checker/src/gnatcheck-rules-rule_table.ads
index 7d051719a..b0409f368 100644
--- a/lkql_checker/lalcheck/gnatcheck-rules-rule_table.ads
+++ b/lkql_checker/src/gnatcheck-rules-rule_table.ads
@@ -148,5 +148,6 @@ package Gnatcheck.Rules.Rule_Table is
procedure Process_Requested_Rules (Ctx : in out Lkql_Context);
-- Process the rules enabled and set Ctx.Traverse_Instantiations
+ -- TODO: Useless? See #190
end Gnatcheck.Rules.Rule_Table;
diff --git a/lkql_checker/lalcheck/gnatcheck-rules.adb b/lkql_checker/src/gnatcheck-rules.adb
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-rules.adb
rename to lkql_checker/src/gnatcheck-rules.adb
diff --git a/lkql_checker/lalcheck/gnatcheck-rules.ads b/lkql_checker/src/gnatcheck-rules.ads
similarity index 99%
rename from lkql_checker/lalcheck/gnatcheck-rules.ads
rename to lkql_checker/src/gnatcheck-rules.ads
index 038da7ef5..1d14ab92d 100644
--- a/lkql_checker/lalcheck/gnatcheck-rules.ads
+++ b/lkql_checker/src/gnatcheck-rules.ads
@@ -99,9 +99,6 @@ package Gnatcheck.Rules is
Subcategory : String_Access;
-- Subcategory for this rule, "" if none
- Follow_Instantiations : Boolean;
- -- True if this rule follows generic instantiations
-
Allows_Parametrized_Exemption : Boolean;
-- Whether you can specify a rule parameter when defining an exemption
-- section for this Rule. In case if a rule parameter has the form like
diff --git a/lkql_checker/lalcheck/gnatcheck-source_table.adb b/lkql_checker/src/gnatcheck-source_table.adb
similarity index 90%
rename from lkql_checker/lalcheck/gnatcheck-source_table.adb
rename to lkql_checker/src/gnatcheck-source_table.adb
index 150e08a3a..7ec87a364 100644
--- a/lkql_checker/lalcheck/gnatcheck-source_table.adb
+++ b/lkql_checker/src/gnatcheck-source_table.adb
@@ -43,11 +43,8 @@ with GPR2.Project.Source.Set;
with Gnatcheck.Diagnoses; use Gnatcheck.Diagnoses;
with Gnatcheck.Ids; use Gnatcheck.Ids;
with Gnatcheck.Output; use Gnatcheck.Output;
-with Gnatcheck.Rules; use Gnatcheck.Rules;
-with Gnatcheck.Rules.Rule_Table; use Gnatcheck.Rules.Rule_Table;
with Gnatcheck.String_Utilities; use Gnatcheck.String_Utilities;
-with Langkit_Support.Slocs; use Langkit_Support.Slocs;
with Langkit_Support.Text; use Langkit_Support.Text;
with Langkit_Support.Generic_API.Introspection;
@@ -60,16 +57,17 @@ with Libadalang.Generic_API; use Libadalang.Generic_API;
with Libadalang.Common;
with Libadalang.Config_Pragmas;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-with LKQL.Errors; use LKQL.Errors;
-with LKQL.Primitives; use LKQL.Primitives;
+with Langkit_Support.Generic_API.Analysis;
-package body Gnatcheck.Source_Table is
+with Liblkqllang.Analysis;
- use Langkit_Support.Generic_API;
+package body Gnatcheck.Source_Table is
+ package LK renames Langkit_Support.Generic_API.Analysis;
package LKI renames Langkit_Support.Generic_API.Introspection;
+ type LK_Unit_Array is array (Positive range <>) of LK.Lk_Unit;
+
subtype String_Access is GNAT.OS_Lib.String_Access;
Arg_File_Name : String_Access;
@@ -260,7 +258,7 @@ package body Gnatcheck.Source_Table is
----------------------------
procedure Add_Sources_To_Context
- (Ctx : Lkql_Context;
+ (Ctx : Checker_App.Lkql_Context;
Project : Arg_Project_Type'Class)
is
use GPR2.Project.View;
@@ -291,13 +289,15 @@ package body Gnatcheck.Source_Table is
end if;
declare
+ use LK;
Lk_Units : LK_Unit_Array (Units.First_Index .. Units.Last_Index);
begin
for I in Lk_Units'Range loop
Lk_Units (I) := To_Generic_Unit (Units (I));
end loop;
- Set_Units (Ctx.Eval_Ctx, Lk_Units);
+ -- Set_Units (Ctx.Eval_Ctx, Lk_Units);
+ -- TODO: Useless ?
end;
end Add_Sources_To_Context;
@@ -1405,11 +1405,9 @@ package body Gnatcheck.Source_Table is
---------------------
procedure Process_Sources
- (Ctx : Lkql_Context; Annotate_Only : Boolean := False)
+ (Ctx : Checker_App.Lkql_Context)
is
Next_SF : SF_Id;
- Cached_Rule_Id : Rule_Id;
- Cached_Rule : Unbounded_Text_Type;
use Libadalang.Iterators;
@@ -1417,98 +1415,6 @@ package body Gnatcheck.Source_Table is
(if S (S'Last) = ASCII.LF then S (S'First .. S'Last - 1) else S);
-- Remove trailing LF if any
- function File_Name (Unit : LK.Lk_Unit) return String is
- (if Full_Source_Locations
- then Unit.Filename
- else Ada.Directories.Simple_Name (Unit.Filename));
- -- Return a string representing the name of Unit, taking
- -- Options.Full_Source_Location into account.
-
- procedure Store_Message
- (Message : Unbounded_Text_Type;
- Unit : LK.Lk_Unit;
- Rule : Unbounded_Text_Type;
- Kind : Message_Kinds;
- Sloc_Range : Source_Location_Range);
- -- Callback to store messages
-
- -------------------
- -- Store_Message --
- -------------------
-
- procedure Store_Message
- (Message : Unbounded_Text_Type;
- Unit : LK.Lk_Unit;
- Rule : Unbounded_Text_Type;
- Kind : Message_Kinds;
- Sloc_Range : Source_Location_Range)
- is
- Id : Rule_Id;
-
- use Ada.Directories;
-
- Msg : constant String := To_String (To_Text (Message));
-
- Actual_SF : SF_Id;
-
- begin
- -- Only store internal error messages in Debug_Mode for now.
- -- Also never store "memoized error" messages which are
- -- cascaded errors.
-
- if (Kind = Internal_Error
- and then not Debug_Mode
- and then Index (Msg, "STOP_EVALUATION_ERROR") = 0)
- or else Has_Suffix (Msg, "(memoized)")
- or else Has_Suffix (Msg, "Memoized Error") -- pending W119-041
- then
- return;
- end if;
-
- GNAT.Task_Lock.Lock;
-
- if Rule = Cached_Rule then
- Id := Cached_Rule_Id;
- else
- Id := Get_Rule (To_String (To_Text (Rule)));
- Cached_Rule_Id := Id;
- Cached_Rule := Rule;
- end if;
-
- -- If Follow_Instantiations is True then the relevant file id
- -- may not be Next_SF, so perform a lookup.
- Actual_SF := File_Find
- (Simple_Name (Unit.Filename), Use_Short_Name => True);
-
- if not Present (Actual_SF) then
- return;
- end if;
-
- if Subprocess_Mode then
- Put_Line
- (File_Name (Unit) & ":" &
- Sloc_Image (Start_Sloc (Sloc_Range)) & ": " &
- "check: " & Msg &
- Annotate_Rule (All_Rules.Table (Id).all));
-
- else
- Store_Diagnosis
- (Text =>
- File_Name (Unit) & ":" &
- Sloc_Image (Start_Sloc (Sloc_Range)) & ": " &
- Msg & (if Id = No_Rule then ""
- else Annotate_Rule (All_Rules.Table (Id).all)),
- Diagnosis_Kind =>
- (if Kind = Rule_Violation then Rule_Violation
- else Internal_Error),
- SF => Actual_SF,
- Rule => Id,
- Justification => Exemption_Justification (Id));
- end if;
-
- GNAT.Task_Lock.Unlock;
- end Store_Message;
-
begin
loop
Next_SF := Next_Non_Processed_Source;
@@ -1519,47 +1425,39 @@ package body Gnatcheck.Source_Table is
Unit : constant Analysis_Unit :=
Ctx.Analysis_Ctx.Get_From_File (Source_Name (Next_SF));
begin
- if not Annotate_Only then
- Output_Source (Next_SF);
- Process_Unit (Ctx, Unit, Store_Message'Access);
- end if;
+ -- Process exemption pragmas for Unit
- if not Subprocess_Mode then
- -- Process exemption pragmas for Unit
-
- declare
- It : Traverse_Iterator'Class := Traverse (Unit.Root);
- Current : Ada_Node;
- Dummy : constant Boolean := It.Next (Current);
-
- use Libadalang.Common;
- begin
- while It.Next (Current) loop
- if Current.Kind = Ada_Pragma_Node
- and then Is_Exemption_Pragma (Current.As_Pragma_Node)
- then
- Process_Exemption_Pragma (Current.As_Pragma_Node);
- end if;
- end loop;
- end;
-
- -- Process exemption comments for Unit
-
- declare
- use Libadalang.Common;
- TR : Token_Reference := Unit.First_Token;
- begin
- while TR /= No_Token loop
- if Kind (Data (TR)) = Ada_Comment then
- Process_Exemption_Comment (TR, Unit);
- end if;
- TR := Next (TR);
- end loop;
- end;
+ declare
+ It : Traverse_Iterator'Class := Traverse (Unit.Root);
+ Current : Ada_Node;
+ Dummy : constant Boolean := It.Next (Current);
- Check_Unclosed_Rule_Exemptions (Next_SF, Unit);
- end if;
+ use Libadalang.Common;
+ begin
+ while It.Next (Current) loop
+ if Current.Kind = Ada_Pragma_Node
+ and then Is_Exemption_Pragma (Current.As_Pragma_Node)
+ then
+ Process_Exemption_Pragma (Current.As_Pragma_Node);
+ end if;
+ end loop;
+ end;
+
+ -- Process exemption comments for Unit
+
+ declare
+ use Libadalang.Common;
+ TR : Token_Reference := Unit.First_Token;
+ begin
+ while TR /= No_Token loop
+ if Kind (Data (TR)) = Ada_Comment then
+ Process_Exemption_Comment (TR, Unit);
+ end if;
+ TR := Next (TR);
+ end loop;
+ end;
+ Check_Unclosed_Rule_Exemptions (Next_SF, Unit);
exception
when E : others =>
if Debug_Mode then
@@ -1589,9 +1487,8 @@ package body Gnatcheck.Source_Table is
Partition : GPR2_Provider_And_Projects_Array_Access;
- function Create_Context return Lkql_Context is
- Ctx : Lkql_Context;
- Dummy : Primitive;
+ function Create_Context return Checker_App.Lkql_Context is
+ Ctx : Checker_App.Lkql_Context;
Files : File_Array_Access;
Last : Natural := 0;
@@ -1755,18 +1652,13 @@ package body Gnatcheck.Source_Table is
(Ctx.Analysis_Ctx, Gnatcheck_Prj.Tree.all);
end if;
- -- It's too early to compute units, so provide an empty value for now,
- -- until Add_Sources_To_Context is called.
-
- Ctx.Eval_Ctx := Make_Eval_Context ([], Ada_Lang_Id);
-
- LKQL.Errors.Property_Error_Recovery := LKQL.Errors.Continue_And_Warn;
-
-- Initialize the cached rules array, with an array that goes from
-- the index of the first root node type, to the index of the last
-- derived type. This array will have too many slots since is has
-- slots for abstract types, but we don't really care.
declare
+ use Checker_App;
+
Root_Node_Type : LKI.Type_Ref
renames LKI.Root_Node_Type (Ada_Lang_Id);
subtype Rules_By_Kind_Array_Subt is
@@ -1778,6 +1670,9 @@ package body Gnatcheck.Source_Table is
Ctx.Cached_Rules := new Rules_By_Kind_Array_Subt;
end;
+ Ctx.LKQL_Analysis_Context := Liblkqllang.Analysis.Create_Context
+ (Charset => "utf-8");
+
return Ctx;
end Create_Context;
diff --git a/lkql_checker/lalcheck/gnatcheck-source_table.ads b/lkql_checker/src/gnatcheck-source_table.ads
similarity index 98%
rename from lkql_checker/lalcheck/gnatcheck-source_table.ads
rename to lkql_checker/src/gnatcheck-source_table.ads
index f4ec4d880..7bb3f5f9b 100644
--- a/lkql_checker/lalcheck/gnatcheck-source_table.ads
+++ b/lkql_checker/src/gnatcheck-source_table.ads
@@ -27,7 +27,7 @@ with GNATCOLL.Projects; use GNATCOLL.Projects;
with Gnatcheck.Options; use Gnatcheck.Options;
with Gnatcheck.Projects; use Gnatcheck.Projects;
-with Checker_App; use Checker_App;
+with Checker_App;
package Gnatcheck.Source_Table is
@@ -204,16 +204,17 @@ package Gnatcheck.Source_Table is
-- progress indicator. (Unconditionally) decreases the counter of the
-- sources which have to be processed (Sources_Left)
- function Create_Context return Lkql_Context;
+ function Create_Context return Checker_App.Lkql_Context;
-- Create the LKQL context
procedure Add_Sources_To_Context
- (Ctx : Lkql_Context;
+ (Ctx : Checker_App.Lkql_Context;
Project : Arg_Project_Type'Class);
-- Add all sources from Project to Ctx
+ -- TODO: MAYBEREMOVE
procedure Process_Sources
- (Ctx : Lkql_Context; Annotate_Only : Boolean := False);
+ (Ctx : Checker_App.Lkql_Context);
-- Procedure all sources. Only process pragma Annotate if Annotate_Only
-- is true.
diff --git a/lkql_checker/lalcheck/gnatcheck-string_utilities.adb b/lkql_checker/src/gnatcheck-string_utilities.adb
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-string_utilities.adb
rename to lkql_checker/src/gnatcheck-string_utilities.adb
diff --git a/lkql_checker/lalcheck/gnatcheck-string_utilities.ads b/lkql_checker/src/gnatcheck-string_utilities.ads
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck-string_utilities.ads
rename to lkql_checker/src/gnatcheck-string_utilities.ads
diff --git a/lkql_checker/lalcheck/gnatcheck.ads b/lkql_checker/src/gnatcheck.ads
similarity index 100%
rename from lkql_checker/lalcheck/gnatcheck.ads
rename to lkql_checker/src/gnatcheck.ads
diff --git a/lkql_checker/lalcheck/lalcheck.adb b/lkql_checker/src/gnatcheck_main.adb
similarity index 90%
rename from lkql_checker/lalcheck/lalcheck.adb
rename to lkql_checker/src/gnatcheck_main.adb
index 724638db8..828a7b207 100644
--- a/lkql_checker/lalcheck/lalcheck.adb
+++ b/lkql_checker/src/gnatcheck_main.adb
@@ -40,16 +40,13 @@ with Gnatcheck.Rules; use Gnatcheck.Rules;
with Gnatcheck.Rules.Rule_Table; use Gnatcheck.Rules.Rule_Table;
with Gnatcheck.String_Utilities; use Gnatcheck.String_Utilities;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
+with Checker_App;
-with Checker_App; use Checker_App;
-with Rules_Factory;
-
-procedure Lalcheck is
+procedure Gnatcheck_Main is
Time_Start : constant Ada.Calendar.Time := Ada.Calendar.Clock;
use type Ada.Calendar.Time;
- Ctx : Lkql_Context;
+ Ctx : Checker_App.Lkql_Context;
GPRbuild_Pid : Process_Id := Invalid_Pid;
E_Success : constant := 0; -- No tool failure, no rule violation detected
@@ -288,7 +285,7 @@ procedure Lalcheck is
begin
-- Process sources to take pragma Annotate into account
- Process_Sources (Ctx, Annotate_Only => True);
+ Process_Sources (Ctx);
for Job in 1 .. Num_Jobs loop
Create (File, Out_File, File_Name ("files", Job));
@@ -423,9 +420,7 @@ begin
-- Exemptions are handled fully in the parent process
- if not Subprocess_Mode then
- Gnatcheck.Diagnoses.Init_Exemptions;
- end if;
+ Gnatcheck.Diagnoses.Init_Exemptions;
if Analyze_Compiler_Output then
Create_Restriction_Pragmas_File;
@@ -442,15 +437,6 @@ begin
-- In this case we spawn gnatcheck for each project being aggregated
Gnatcheck.Projects.Aggregate.Process_Aggregated_Projects (Gnatcheck_Prj);
- elsif Subprocess_Mode then
- -- The call to Create_Context above was made before sources are computed
- -- by Check_Parameters, so reset them now.
-
- Add_Sources_To_Context (Ctx, Gnatcheck_Prj);
- Process_Sources (Ctx);
- Rules_Factory.Finalize_Rules (Ctx.Eval_Ctx);
- Free_Eval_Context (Ctx.Eval_Ctx);
-
else
-- The call to Create_Context above was made before sources are computed
-- by Check_Parameters, so reset them now.
@@ -461,47 +447,10 @@ begin
-- In the default (-j1, no custom worker) mode, process all sources in
-- the main process.
- if Process_Num <= 1 and then not Use_External_Worker then
-
- -- Spawn gprbuild in background to process the files in parallel
-
- if Analyze_Compiler_Output then
- GPRbuild_Pid := Spawn_GPRbuild
- (Global_Report_Dir.all & "gprbuild.err");
- end if;
-
- Process_Sources (Ctx);
-
- -- Wait for gprbuild to finish if we've launched it earlier and
- -- analyze its output.
-
- if Analyze_Compiler_Output then
- declare
- Ignore : Boolean;
- Pid : Process_Id;
- begin
- if not Quiet_Mode then
- Info ("Waiting for gprbuild...");
- end if;
-
- Wait_Process (Pid, Ignore);
-
- if Pid = GPRbuild_Pid then
- Analyze_Output (Global_Report_Dir.all & "gprbuild.err",
- Ignore);
- else
- Info ("Error while waiting for gprbuild process.");
- end if;
- end;
- end if;
- else
- Schedule_Files;
- end if;
+ Schedule_Files;
Generate_Qualification_Report;
Gnatcheck.Output.Close_Report_Files;
- Rules_Factory.Finalize_Rules (Ctx.Eval_Ctx);
- Free_Eval_Context (Ctx.Eval_Ctx);
if Tool_Failures > 0 then
Info ("Total gnatcheck failures:" & Tool_Failures'Img);
@@ -550,4 +499,4 @@ exception
Gnatcheck.Output.Report_Unhandled_Exception (Ex);
Gnatcheck.Projects.Clean_Up (Gnatcheck_Prj);
OS_Exit (E_Error);
-end Lalcheck;
+end Gnatcheck_Main;
diff --git a/lkql_checker/src/lkql_checker.adb b/lkql_checker/src/lkql_checker.adb
deleted file mode 100644
index 23c913ecf..000000000
--- a/lkql_checker/src/lkql_checker.adb
+++ /dev/null
@@ -1,38 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- LKQL --
--- --
--- Copyright (C) 2019-2023, AdaCore --
--- --
--- LKQL is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This software 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. --
--- --
--- 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 --
--- . --
-------------------------------------------------------------------------------
-
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.OS_Lib;
-
-with Checker_App;
-
-procedure Lkql_Checker is
-begin
- Checker_App.App.Run;
-exception
- when E : Checker_App.Exit_App =>
- Put_Line ("ERROR: " & Exception_Message (E));
- GNAT.OS_Lib.OS_Exit (1);
-end Lkql_Checker;
diff --git a/lkql_checker/src/rule_commands.adb b/lkql_checker/src/rule_commands.adb
index 3d3b429b8..300903446 100644
--- a/lkql_checker/src/rule_commands.adb
+++ b/lkql_checker/src/rule_commands.adb
@@ -24,14 +24,10 @@
with Ada.Characters.Conversions; use Ada.Characters.Conversions;
with Ada.Strings.Wide_Wide_Unbounded; use Ada.Strings.Wide_Wide_Unbounded;
-with LKQL.Unit_Utils; use LKQL.Unit_Utils;
-with LKQL.Evaluation; use LKQL.Evaluation;
-
with Liblkqllang.Common;
with Liblkqllang.Generic_API.Introspection;
use Liblkqllang.Generic_API.Introspection;
with Liblkqllang.Iterators; use Liblkqllang.Iterators;
-with LKQL.Primitives; use LKQL.Primitives;
package body Rule_Commands is
@@ -114,11 +110,11 @@ package body Rule_Commands is
function Create_Rule_Command
(Lkql_File_Path : String;
- Ctx : Eval_Context;
+ Ctx : L.Analysis_Context;
Rc : out Rule_Command) return Boolean
is
Root : constant L.Lkql_Node :=
- Make_Lkql_Unit (Ctx, Lkql_File_Path).Root;
+ Ctx.Get_From_File (Lkql_File_Path).Root;
Check_Annotation : constant L.Decl_Annotation :=
Find_First
@@ -169,10 +165,6 @@ package body Rule_Commands is
Name : constant Text_Type := Fn.F_Name.Text;
Toplevel_Node_Pattern : L.Node_Kind_Pattern;
- Follow_Instantiations_Arg : constant L.Arg :=
- Check_Annotation.P_Arg_With_Name
- (To_Unbounded_Text ("follow_generic_instantiations"));
- Follow_Instantiations : Boolean := False;
Param_Kind : Rule_Param_Kind;
use LCO, GNAT.Regexp;
@@ -234,16 +226,9 @@ package body Rule_Commands is
-- Get the "follow_generic_instantiations" settings if the user
-- specified one. By default it is false.
- if not Follow_Instantiations_Arg.Is_Null then
- Follow_Instantiations :=
- Bool_Val
- (Eval (Ctx, Follow_Instantiations_Arg.P_Expr, Kind_Bool));
- end if;
-
if not Parametric_Exemption_Arg.Is_Null then
Parametric_Exemption :=
- Bool_Val
- (Eval (Ctx, Parametric_Exemption_Arg.P_Expr, Kind_Bool));
+ Parametric_Exemption_Arg.P_Expr.Text = "true";
end if;
Get_Text (Msg_Arg, To_Unbounded_Text (Name), Msg);
@@ -318,13 +303,11 @@ package body Rule_Commands is
Subcategory => Subcategory,
Lkql_Root => Root,
Function_Expr => Fn.F_Fun_Expr.F_Body_Expr,
- Eval_Ctx => Ctx.Create_New_Frame,
Rule_Args => <>,
Is_Unit_Check =>
Check_Annotation.F_Name.Text = "unit_check",
Code => <>,
Kind_Pattern => Toplevel_Node_Pattern,
- Follow_Instantiations => Follow_Instantiations,
Param_Kind => Param_Kind,
Parameters => Fn.F_Fun_Expr.F_Parameters,
Remediation_Level => Remediation_Level,
@@ -335,75 +318,4 @@ package body Rule_Commands is
end;
end Create_Rule_Command;
- -------------
- -- Prepare --
- -------------
-
- procedure Prepare (Self : in out Rule_Command) is
- Code : Unbounded_Text_Type;
- begin
- -- Create the code snippet that will be passed to Lkql_Eval, along with
- -- the optional arguments passed to the rule via the command line.
-
- Append (Code, To_Text (Self.Name));
- Append (Code, "(");
- for I in Self.Rule_Args.First_Index .. Self.Rule_Args.Last_Index loop
- Append (Code,
- To_Text (Self.Rule_Args (I).Name)
- & "="
- & To_Text (Self.Rule_Args (I).Value));
- if I < Self.Rule_Args.Last_Index then
- Append (Code, ", ");
- end if;
- end loop;
- Append (Code, ")");
-
- Self.Code :=
- Make_Lkql_Unit_From_Code
- (Self.Eval_Ctx,
- Image (To_Text (Code)),
- "[" & Image (To_Text (Self.Name)) & " inline code]").Root;
-
- if not Self.Is_Unit_Check then
- -- For node checks, we optimize away the function call, so we will
- -- add the parameters values to the environment.
-
- -- First add bindings for formals who have default param values
- for Param of
- Self.Function_Expr.Parent.As_Base_Function.P_Default_Parameters
- loop
- Self.Eval_Ctx.Add_Binding
- (Param.F_Param_Identifier.Text,
- Eval
- (Self.Eval_Ctx,
- Param.F_Default_Expr));
- end loop;
-
- -- Then add bindings for all explicitly passed parameters
- for I in Self.Rule_Args.First_Index + 1 .. Self.Rule_Args.Last_Index
- loop
- Self.Eval_Ctx.Add_Binding
- (To_Text (Self.Rule_Args (I).Name),
- Eval
- (Self.Eval_Ctx,
- Make_Lkql_Unit_From_Code
- (Self.Eval_Ctx,
- Image (To_Text (Self.Rule_Args (I).Value)),
- "[" & Image (To_Text (Self.Name)) & " inline code]")
- .Root.Child (1)));
- end loop;
-
- end if;
-
- end Prepare;
-
- -------------
- -- Destroy --
- -------------
-
- procedure Destroy (Self : in out Rule_Command) is
- begin
- Self.Eval_Ctx.Release_Current_Frame;
- end Destroy;
-
end Rule_Commands;
diff --git a/lkql_checker/src/rule_commands.ads b/lkql_checker/src/rule_commands.ads
index a8cf880ef..5d9efaf1a 100644
--- a/lkql_checker/src/rule_commands.ads
+++ b/lkql_checker/src/rule_commands.ads
@@ -24,8 +24,6 @@
with Ada.Containers.Vectors;
with GNAT.Regexp;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-
with Liblkqllang.Analysis;
with Libadalang.Analysis;
@@ -102,18 +100,10 @@ package Rule_Commands is
-- returns a list of messages) or a node check (function that returns a
-- node).
- Eval_Ctx : Eval_Context;
- -- LKQL eval context in which to eval the rule. Each rule will have a
- -- separate frame, so as to not leak identifier from one rule to the
- -- other.
-
Kind_Pattern : L.Node_Kind_Pattern;
-- If we determined that the rule only needs to run on a specific node
-- kind, store the corresponding node pattern here.
- Follow_Instantiations : Boolean;
- -- Whether we should follow generic instantiations or not for this rule.
-
Param_Kind : Rule_Param_Kind;
-- Category of parameters.
@@ -124,7 +114,6 @@ package Rule_Commands is
-- Remediation level to compute technical debt.
Parametric_Exemption : Boolean;
- -- Whether this rule allows parametric exemption.
Impact : Regexp_Access;
-- For a KP detector, regexp to match relevant releases impacted, if
@@ -148,17 +137,12 @@ package Rule_Commands is
package Eval_Diagnostic_Vectors
is new Ada.Containers.Vectors (Positive, Eval_Diagnostic);
- procedure Prepare (Self : in out Rule_Command);
-
function Create_Rule_Command
(Lkql_File_Path : String;
- Ctx : Eval_Context;
+ Ctx : L.Analysis_Context;
Rc : out Rule_Command) return Boolean;
-- Create a Rule_Command value with the given name and arguments and
-- store it in ``Rc``. Return ``True`` if this succeeded, ie. the file
-- corresponds to a rule file, ``False`` otherwise.
- procedure Destroy (Self : in out Rule_Command);
- -- Destroy the rule and associated data
-
end Rule_Commands;
diff --git a/lkql_checker/src/rules_factory.adb b/lkql_checker/src/rules_factory.adb
index 4db992a54..99d11b5f4 100644
--- a/lkql_checker/src/rules_factory.adb
+++ b/lkql_checker/src/rules_factory.adb
@@ -34,7 +34,7 @@ package body Rules_Factory is
---------------
function All_Rules
- (Ctx : in out Eval_Context;
+ (Ctx : L.Analysis_Context;
Dirs : Path_Vector := Path_Vectors.Empty_Vector) return Rule_Vector
is
Rules_Dirs : constant Virtual_File_Array := Get_Rules_Directories (Dirs);
@@ -48,7 +48,6 @@ package body Rules_Factory is
for Rules_Dir of Rules_Dirs loop
if Is_Directory (Rules_Dir) then
- Ctx.Add_Lkql_Path (+Rules_Dir.Full_Name);
declare
Dir : File_Array_Access := Read_Dir (Rules_Dir);
@@ -123,13 +122,4 @@ package body Rules_Factory is
end;
end Get_Rules_Directories;
- --------------------
- -- Finalize_Rules --
- --------------------
-
- procedure Finalize_Rules (Ctx : Eval_Context) is
- begin
- null;
- end Finalize_Rules;
-
end Rules_Factory;
diff --git a/lkql_checker/src/rules_factory.ads b/lkql_checker/src/rules_factory.ads
index 6bcffd166..7b5e5ed8f 100644
--- a/lkql_checker/src/rules_factory.ads
+++ b/lkql_checker/src/rules_factory.ads
@@ -30,8 +30,6 @@ with Ada.Containers.Indefinite_Vectors;
with Ada.Containers.Vectors;
with Ada.Strings.Hash;
-with LKQL.Eval_Contexts; use LKQL.Eval_Contexts;
-
with GNATCOLL.VFS; use GNATCOLL.VFS;
package Rules_Factory is
@@ -51,15 +49,11 @@ package Rules_Factory is
subtype Path_Vector is Path_Vectors.Vector;
function All_Rules
- (Ctx : in out Eval_Context;
+ (Ctx : L.Analysis_Context;
Dirs : Path_Vector := Path_Vectors.Empty_Vector) return Rule_Vector;
-- Return a vector containing Rule_Command values for every implemented
-- check.
- procedure Finalize_Rules (Ctx : Eval_Context);
- -- Free memory associated to rules. Needs to be called at the end of the
- -- program.
-
private
type Virtual_File_Array is array (Positive range <>) of Virtual_File;
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/LKQLLanguage.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/LKQLLanguage.java
index 1f02be285..ab9d72702 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/LKQLLanguage.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/LKQLLanguage.java
@@ -23,7 +23,6 @@
package com.adacore.lkql_jit;
import com.adacore.liblkqllang.Liblkqllang;
-import com.adacore.lkql_jit.built_ins.BuiltInFactory;
import com.adacore.lkql_jit.exception.LKQLRuntimeException;
import com.adacore.lkql_jit.langkit_translator.LangkitTranslator;
import com.adacore.lkql_jit.nodes.LKQLNode;
@@ -264,12 +263,8 @@ public static LKQLLanguage getLanguage(LKQLNode node) {
*/
@Override
protected LKQLContext createContext(Env env) {
- // Get the built-in factory
- BuiltInFactory factory = BuiltInFactory.getInstance();
-
// Create the global values
- GlobalScope globalValues = new GlobalScope(factory.getNbBuiltInFunctions());
- factory.addBuiltIns(globalValues);
+ GlobalScope globalValues = new GlobalScope();
// Return the new context
return new LKQLContext(env, globalValues);
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInFactory.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInFactory.java
deleted file mode 100644
index 57402c4f3..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInFactory.java
+++ /dev/null
@@ -1,180 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins;
-
-import com.adacore.lkql_jit.built_ins.functions.*;
-import com.adacore.lkql_jit.built_ins.methods.*;
-import com.adacore.lkql_jit.built_ins.selectors.*;
-import com.adacore.lkql_jit.langkit_translator.passes.framing_utils.ScriptFramesBuilder;
-import com.adacore.lkql_jit.runtime.GlobalScope;
-import java.util.ArrayList;
-import java.util.List;
-
-/**
- * This class is a helper to add all built-ins of LKQL in the context and scope.
- *
- * @author Hugo GUERRIER
- */
-public final class BuiltInFactory {
-
- // ----- Attributes -----
-
- /** The only instance of the built-in factory. */
- private static BuiltInFactory instance = null;
-
- /** The built-in function list. */
- private final List builtInFunctions;
-
- /** The built-in selector list. */
- private final List builtInSelectors;
-
- /** The built-in method list. */
- private final List builtInMethods;
-
- // ----- Static initializer -----
-
- /** Create a build in factory as a singleton. */
- private BuiltInFactory() {
- this.builtInFunctions = new ArrayList<>();
- this.builtInSelectors = new ArrayList<>();
- this.builtInMethods = new ArrayList<>();
-
- this.initializeFunctions();
- this.initializeSelectors();
- this.initializeMethods();
- }
-
- /**
- * Get the only built-in factory instance.
- *
- * @return The factory instance.
- */
- public static BuiltInFactory getInstance() {
- if (instance == null) {
- instance = new BuiltInFactory();
- }
- return instance;
- }
-
- /** Initialize the built-in functions. */
- private void initializeFunctions() {
- this.builtInFunctions.add(PrintFunction.getValue());
- this.builtInFunctions.add(ImgFunction.getValue());
- this.builtInFunctions.add(BaseNameFunction.getValue());
- this.builtInFunctions.add(ConcatFunction.getValue());
- this.builtInFunctions.add(ReduceFunction.getValue());
- this.builtInFunctions.add(MapFunction.getValue());
- this.builtInFunctions.add(UniqueFunction.getValue());
- this.builtInFunctions.add(DocFunction.getValue());
- this.builtInFunctions.add(ProfileFunction.getValue());
- this.builtInFunctions.add(HelpFunction.getValue());
- this.builtInFunctions.add(UnitsFunction.getValue());
- this.builtInFunctions.add(SpecifiedUnitsFunction.getValue());
- this.builtInFunctions.add(PatternFunction.getValue());
- this.builtInFunctions.add(NodeCheckerFunction.getValue());
- this.builtInFunctions.add(UnitCheckerFunction.getValue());
- }
-
- /** Initialize the built-in selectors. */
- private void initializeSelectors() {
- this.builtInSelectors.add(ChildrenSelector.getInstance());
- this.builtInSelectors.add(ParentSelector.getInstance());
- this.builtInSelectors.add(NextSiblingsSelector.getInstance());
- this.builtInSelectors.add(PrevSiblingsSelector.getInstance());
- this.builtInSelectors.add(SuperTypesSelector.getInstance());
- }
-
- /** Initialize the built-in methods. */
- private void initializeMethods() {
- this.builtInMethods.add(UnitMethods.getInstance());
- this.builtInMethods.add(BoolMethods.getInstance());
- this.builtInMethods.add(IntMethods.getInstance());
- this.builtInMethods.add(StrMethods.getInstance());
- this.builtInMethods.add(FunctionMethods.getInstance());
- this.builtInMethods.add(PropertyRefMethods.getInstance());
- this.builtInMethods.add(SelectorMethods.getInstance());
- this.builtInMethods.add(TupleMethods.getInstance());
- this.builtInMethods.add(ListMethods.getInstance());
- this.builtInMethods.add(SelectorListMethods.getInstance());
- this.builtInMethods.add(LazyListMethods.getInstance());
- this.builtInMethods.add(ObjectMethods.getInstance());
- this.builtInMethods.add(NamespaceMethods.getInstance());
- this.builtInMethods.add(NodeMethods.getInstance());
- this.builtInMethods.add(TokenMethods.getInstance());
- this.builtInMethods.add(AnalysisUnitMethods.getInstance());
- }
-
- // ----- Getters -----
-
- /**
- * Get the number of built-in occupied slots (functions + selectors).
- *
- * @return The number of reserved slots.
- */
- public int getNbBuiltInFunctions() {
- return this.builtInFunctions.size() + this.builtInSelectors.size();
- }
-
- // ----- Instance methods -----
-
- /**
- * Add all LKQL built-ins to the given context global values.
- *
- * @param globalValues The global value object to put the built-ins in.
- */
- public void addBuiltIns(GlobalScope globalValues) {
- // Add the built-in functions
- for (int i = 0; i < this.builtInFunctions.size(); i++) {
- BuiltInFunctionValue function = this.builtInFunctions.get(i);
- globalValues.setBuiltIn(i, function);
- }
-
- // Add the built-in selectors
- for (int i = 0; i < this.builtInSelectors.size(); i++) {
- BuiltInSelector selector = this.builtInSelectors.get(i);
- globalValues.setBuiltIn(i + this.builtInFunctions.size(), selector.getValue());
- }
-
- // Add the built-in methods
- for (BuiltInMethods builtInMethods : this.builtInMethods) {
- globalValues.putMetaTable(builtInMethods.getType(), builtInMethods.getMethods());
- }
- }
-
- /**
- * Add the built ins to the script frames builder.
- *
- * @param scriptFramesBuilder The script frames builder to add the built-ins in.
- */
- public void addBuiltIns(final ScriptFramesBuilder scriptFramesBuilder) {
- // Add the built-in functions
- for (BuiltInFunctionValue function : this.builtInFunctions) {
- scriptFramesBuilder.addBuiltIn(function.getName());
- }
-
- // Add the built-in selectors
- for (BuiltInSelector selector : this.builtInSelectors) {
- scriptFramesBuilder.addBuiltIn(selector.getName());
- }
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInFunctionValue.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInFunctionValue.java
index a21097f78..5d4b389bb 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInFunctionValue.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInFunctionValue.java
@@ -28,6 +28,7 @@
import com.adacore.lkql_jit.nodes.root_nodes.FunctionRootNode;
import com.adacore.lkql_jit.runtime.Closure;
import com.oracle.truffle.api.frame.VirtualFrame;
+import java.util.Map;
/**
* This class represents the base of a built-in function value.
@@ -118,4 +119,22 @@ public void setCallNode(FunCall callNode) {
public interface BuiltinFunctionCallback {
public Object apply(VirtualFrame frame, FunCall call);
}
+
+ public static Map.Entry create(
+ String name,
+ String doc,
+ String[] names,
+ Expr[] defaultValues,
+ BuiltinFunctionCallback callback) {
+ return Map.entry(name, new BuiltInFunctionValue(name, doc, names, defaultValues, callback));
+ }
+
+ public static Map.Entry create(
+ String name,
+ String doc,
+ String[] names,
+ Expr[] defaultValues,
+ BuiltinFunctionBody body) {
+ return Map.entry(name, new BuiltInFunctionValue(name, doc, names, defaultValues, body));
+ }
}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInsHolder.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInsHolder.java
new file mode 100644
index 000000000..ca48f672c
--- /dev/null
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInsHolder.java
@@ -0,0 +1,119 @@
+/*----------------------------------------------------------------------------
+-- L K Q L J I T --
+-- --
+-- Copyright (C) 2022-2023, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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 --
+-- --
+----------------------------------------------------------------------------*/
+
+package com.adacore.lkql_jit.built_ins;
+
+import com.adacore.lkql_jit.built_ins.functions.*;
+import com.adacore.lkql_jit.built_ins.methods.*;
+import com.adacore.lkql_jit.built_ins.selectors.*;
+import com.adacore.lkql_jit.utils.LKQLTypesHelper;
+import java.util.HashMap;
+import java.util.List;
+import java.util.Map;
+
+/**
+ * This class is a data class helper containing all built-ins of LKQL.
+ *
+ * @author Hugo GUERRIER
+ */
+public final class BuiltInsHolder {
+ /** The built-in function list. */
+ public final List builtInFunctions =
+ List.of(
+ PrintFunction.getValue(),
+ ImgFunction.getValue(),
+ BaseNameFunction.getValue(),
+ ConcatFunction.getValue(),
+ ReduceFunction.getValue(),
+ MapFunction.getValue(),
+ UniqueFunction.getValue(),
+ DocFunction.getValue(),
+ ProfileFunction.getValue(),
+ DocumentBuiltins.getValue(),
+ DocumentNamespace.getValue(),
+ HelpFunction.getValue(),
+ UnitsFunction.getValue(),
+ SpecifiedUnitsFunction.getValue(),
+ PatternFunction.getValue(),
+ NodeCheckerFunction.getValue(),
+ UnitCheckerFunction.getValue());
+
+ /** The built-in selector list. */
+ public final List builtInSelectors =
+ List.of(
+ ChildrenSelector.getInstance(),
+ ParentSelector.getInstance(),
+ NextSiblingsSelector.getInstance(),
+ PrevSiblingsSelector.getInstance(),
+ SuperTypesSelector.getInstance());
+
+ /** The built-in method list. */
+ public final Map> builtInMethods =
+ Map.ofEntries(
+ create(LKQLTypesHelper.LKQL_LIST, ListMethods.methods),
+ create(LKQLTypesHelper.LKQL_STRING, StrMethods.methods),
+ create(LKQLTypesHelper.ADA_NODE, NodeMethods.methods),
+ create(LKQLTypesHelper.ANALYSIS_UNIT, AnalysisUnitMethods.methods),
+ create(LKQLTypesHelper.TOKEN, TokenMethods.methods),
+ create(LKQLTypesHelper.LKQL_LAZY_LIST, IterableMethods.methods),
+ create(LKQLTypesHelper.LKQL_SELECTOR_LIST, IterableMethods.methods),
+ create(LKQLTypesHelper.LKQL_UNIT, null),
+ create(LKQLTypesHelper.LKQL_BOOLEAN, null),
+ create(LKQLTypesHelper.LKQL_INTEGER, null),
+ create(LKQLTypesHelper.LKQL_FUNCTION, null),
+ create(LKQLTypesHelper.LKQL_PROPERTY_REF, null),
+ create(LKQLTypesHelper.LKQL_SELECTOR, null),
+ create(LKQLTypesHelper.LKQL_TUPLE, null),
+ create(LKQLTypesHelper.LKQL_OBJECT, null),
+ create(LKQLTypesHelper.LKQL_NAMESPACE, null));
+
+ public final Map commonMethods =
+ Map.of(
+ ImgFunction.NAME, ImgFunction.getValue(),
+ PrintFunction.NAME, PrintFunction.getValue(),
+ DocFunction.NAME, DocFunction.getValue());
+
+ public static Map combine(
+ Map m1, Map m2) {
+ var res = new HashMap();
+ res.putAll(m1);
+ res.putAll(m2);
+ return res;
+ }
+
+ private static Map.Entry> create(
+ String name, Map vals) {
+ if (vals == null) {
+ vals = new HashMap<>();
+ }
+ return Map.entry(name, vals);
+ }
+
+ private static BuiltInsHolder instance = null;
+
+ public static BuiltInsHolder get() {
+ if (instance == null) {
+ instance = new BuiltInsHolder();
+ }
+ return instance;
+ }
+}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/DocumentBuiltins.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/DocumentBuiltins.java
new file mode 100644
index 000000000..7b2aa9cde
--- /dev/null
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/DocumentBuiltins.java
@@ -0,0 +1,138 @@
+/*----------------------------------------------------------------------------
+-- L K Q L J I T --
+-- --
+-- Copyright (C) 2022-2023, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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 --
+-- --
+----------------------------------------------------------------------------*/
+
+package com.adacore.lkql_jit.built_ins.functions;
+
+import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
+import com.adacore.lkql_jit.built_ins.BuiltInsHolder;
+import com.adacore.lkql_jit.nodes.expressions.Expr;
+import com.adacore.lkql_jit.nodes.expressions.FunCall;
+import com.adacore.lkql_jit.utils.TextWriter;
+import com.oracle.truffle.api.CompilerDirectives;
+import com.oracle.truffle.api.frame.MaterializedFrame;
+import com.oracle.truffle.api.frame.VirtualFrame;
+import java.io.StringWriter;
+import java.util.Map;
+
+public class DocumentBuiltins {
+ public static final String NAME = "document_builtins";
+
+ @CompilerDirectives.TruffleBoundary
+ public static String documentBuiltinsImpl(MaterializedFrame frame, FunCall call) {
+ var sw = new StringWriter();
+ try (TextWriter writer = new TextWriter(sw)) {
+ writer.write("Standard library\n");
+ writer.write("----------------\n");
+ writer.write("\n");
+ writer.write("Builtin functions\n");
+ writer.write("^^^^^^^^^^^^^^^^^\n");
+ writer.write("\n");
+
+ for (var func : BuiltInsHolder.get().builtInFunctions) {
+ writer.write(".. function:: ");
+ writer.write(func.getName());
+ writer.write("(" + String.join(", ", func.parameterNames) + ")");
+ writer.write("\n\n");
+ writer.withIndent(
+ () -> {
+ writer.write(func.documentation);
+ });
+ writer.write("\n");
+ writer.write("\n");
+ }
+
+ writer.write("Builtin selectors\n");
+ writer.write("^^^^^^^^^^^^^^^^^\n");
+ writer.write("\n");
+
+ for (var sel : BuiltInsHolder.get().builtInSelectors) {
+ writer.write(".. function:: ");
+ writer.write(sel.getName());
+ writer.write("()");
+ writer.write("\n\n");
+ writer.withIndent(
+ () -> {
+ writer.write(sel.getValue().lkqlDocumentation());
+ });
+ writer.write("\n");
+ writer.write("\n");
+ }
+
+ writer.write("Builtin methods\n");
+ writer.write("^^^^^^^^^^^^^^^\n");
+ writer.write("\n");
+
+ var sortedBuiltinMethods =
+ new java.util.ArrayList<>(
+ BuiltInsHolder.get().builtInMethods.entrySet().stream()
+ .sorted(Map.Entry.comparingByKey())
+ .toList());
+
+ sortedBuiltinMethods.add(0, Map.entry("Any", BuiltInsHolder.get().commonMethods));
+
+ for (var entry : sortedBuiltinMethods) {
+
+ var methods =
+ entry.getValue().entrySet().stream()
+ .sorted(Map.Entry.comparingByKey())
+ .toList();
+
+ // Skip type if there are no methods to document
+ if (methods.size() == 0) {
+ continue;
+ }
+
+ var typeName = entry.getKey();
+ var header = "Methods for `" + typeName + "`";
+ writer.write(header + "\n");
+ writer.write("\"".repeat(header.length()) + "\n");
+
+ for (var method : methods) {
+ writer.write(".. method:: ");
+ writer.write(typeName + "." + method.getKey());
+ writer.write("(" + String.join(", ", method.getValue().parameterNames) + ")");
+ writer.write("\n\n");
+ writer.withIndent(
+ () -> {
+ writer.write(method.getValue().documentation);
+ });
+ writer.write("\n");
+ writer.write("\n");
+ }
+ }
+
+ return sw.getBuffer().toString();
+ } catch (Exception e) {
+ throw new RuntimeException(e);
+ }
+ }
+
+ public static BuiltInFunctionValue getValue() {
+ return new BuiltInFunctionValue(
+ NAME,
+ "Return a string in the RsT format containing documentation for all built-ins",
+ new String[] {},
+ new Expr[] {},
+ (VirtualFrame frame, FunCall call) ->
+ documentBuiltinsImpl(frame.materialize(), call));
+ }
+}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/DocumentNamespace.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/DocumentNamespace.java
new file mode 100644
index 000000000..689e95078
--- /dev/null
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/DocumentNamespace.java
@@ -0,0 +1,124 @@
+/*----------------------------------------------------------------------------
+-- L K Q L J I T --
+-- --
+-- Copyright (C) 2022-2023, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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 --
+-- --
+----------------------------------------------------------------------------*/
+
+package com.adacore.lkql_jit.built_ins.functions;
+
+import com.adacore.lkql_jit.LKQLTypeSystemGen;
+import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
+import com.adacore.lkql_jit.built_ins.values.LKQLFunction;
+import com.adacore.lkql_jit.built_ins.values.LKQLNamespace;
+import com.adacore.lkql_jit.built_ins.values.LKQLSelector;
+import com.adacore.lkql_jit.built_ins.values.bases.BasicLKQLValue;
+import com.adacore.lkql_jit.exception.LKQLRuntimeException;
+import com.adacore.lkql_jit.nodes.expressions.Expr;
+import com.adacore.lkql_jit.nodes.expressions.FunCall;
+import com.adacore.lkql_jit.utils.LKQLTypesHelper;
+import com.adacore.lkql_jit.utils.TextWriter;
+import com.oracle.truffle.api.CompilerDirectives;
+import com.oracle.truffle.api.frame.MaterializedFrame;
+import com.oracle.truffle.api.frame.VirtualFrame;
+import java.io.StringWriter;
+import java.util.Comparator;
+
+public class DocumentNamespace {
+ public static final String NAME = "document_namespace";
+
+ public static BuiltInFunctionValue getValue() {
+ return new BuiltInFunctionValue(
+ NAME,
+ "Return a string in the RsT format containing documentation for all built-ins",
+ new String[] {"namespace", "name"},
+ new Expr[] {null, null},
+ (VirtualFrame frame, FunCall call) -> impl(frame.materialize(), call));
+ }
+
+ @CompilerDirectives.TruffleBoundary
+ private static Object impl(MaterializedFrame frame, FunCall call) {
+ Object nsObj = frame.getArguments()[0];
+ Object nameObj = frame.getArguments()[1];
+
+ if (!LKQLTypeSystemGen.isLKQLNamespace(nsObj)) {
+ throw LKQLRuntimeException.wrongType(
+ LKQLTypesHelper.LKQL_NAMESPACE,
+ LKQLTypesHelper.fromJava(nsObj),
+ call.getArgList().getArgs()[0]);
+ }
+
+ if (!LKQLTypeSystemGen.isString(nameObj)) {
+ throw LKQLRuntimeException.wrongType(
+ LKQLTypesHelper.LKQL_STRING,
+ LKQLTypesHelper.fromJava(nameObj),
+ call.getArgList().getArgs()[1]);
+ }
+
+ LKQLNamespace namespace = LKQLTypeSystemGen.asLKQLNamespace(nsObj);
+ String name = LKQLTypeSystemGen.asString(nameObj);
+
+ var sw = new StringWriter();
+ try (TextWriter writer = new TextWriter(sw)) {
+
+ var header = name + "'s API doc";
+ writer.write(header + "\n");
+ writer.write("-".repeat(header.length()));
+ writer.write("\n\n");
+
+ writer.write("Functions\n");
+ writer.write("^^^^^^^^^\n");
+
+ var functions =
+ namespace.asMap().values().stream()
+ .filter(LKQLTypeSystemGen::isLKQLFunction)
+ .map(LKQLTypeSystemGen::asLKQLFunction)
+ .sorted(Comparator.comparing(LKQLFunction::getName));
+
+ for (var func : functions.toList()) {
+ documentCallable(writer, func);
+ }
+
+ writer.write("Selectors\n");
+ writer.write("^^^^^^^^^\n");
+
+ var selectors =
+ namespace.asMap().values().stream()
+ .filter(LKQLTypeSystemGen::isLKQLSelector)
+ .map(LKQLTypeSystemGen::asLKQLSelector)
+ .sorted(Comparator.comparing(LKQLSelector::lkqlProfile));
+
+ for (var sel : selectors.toList()) {
+ documentCallable(writer, sel);
+ }
+
+ return sw.getBuffer().toString();
+ } catch (Exception e) {
+ throw new RuntimeException(e);
+ }
+ }
+
+ private static void documentCallable(TextWriter writer, BasicLKQLValue callable) {
+ writer.write(".. function:: " + callable.lkqlProfile() + "\n\n");
+ writer.withIndent(
+ () -> {
+ writer.write(callable.lkqlDocumentation());
+ });
+ writer.write("\n\n");
+ }
+}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/MapFunction.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/MapFunction.java
index a2e06ca39..29e01873a 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/MapFunction.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/MapFunction.java
@@ -95,7 +95,7 @@ public Object executeGeneric(VirtualFrame frame) {
}
// Verify the function arrity
- if (mapFunction.getParameterNames().length != 1) {
+ if (mapFunction.parameterNames.length != 1) {
throw LKQLRuntimeException.fromMessage(
"Function passed to map should have arity of one",
this.callNode.getArgList().getArgs()[1]);
@@ -111,9 +111,7 @@ public Object executeGeneric(VirtualFrame frame) {
try {
res[i] =
this.interopLibrary.execute(
- mapFunction,
- mapFunction.getClosure().getContent(),
- iterator.next());
+ mapFunction, mapFunction.closure.getContent(), iterator.next());
} catch (ArityException
| UnsupportedTypeException
| UnsupportedMessageException e) {
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/NodeCheckerFunction.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/NodeCheckerFunction.java
index 328c1f4f7..67a43ccd9 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/NodeCheckerFunction.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/NodeCheckerFunction.java
@@ -267,10 +267,10 @@ private void applyNodeRule(
String lowerRuleName = StringUtils.toLowerCase(checker.getName());
// Prepare the arguments
- Object[] arguments = new Object[functionValue.getParameterNames().length + 1];
+ Object[] arguments = new Object[functionValue.parameterNames.length + 1];
arguments[1] = node;
- for (int i = 1; i < functionValue.getParameterDefaultValues().length; i++) {
- String paramName = functionValue.getParameterNames()[i];
+ for (int i = 1; i < functionValue.parameterDefaultValues.length; i++) {
+ String paramName = functionValue.parameterNames[i];
Object userDefinedArg =
context.getRuleArg(
(aliasName == null
@@ -279,12 +279,12 @@ private void applyNodeRule(
StringUtils.toLowerCase(paramName));
arguments[i + 1] =
userDefinedArg == null
- ? functionValue.getParameterDefaultValues()[i].executeGeneric(frame)
+ ? functionValue.parameterDefaultValues[i].executeGeneric(frame)
: userDefinedArg;
}
// Place the closure in the arguments
- arguments[0] = functionValue.getClosure().getContent();
+ arguments[0] = functionValue.closure.getContent();
// Call the checker
final boolean ruleResult;
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/ReduceFunction.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/ReduceFunction.java
index bd758dfc6..fdfa45f72 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/ReduceFunction.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/ReduceFunction.java
@@ -95,7 +95,7 @@ public Object executeGeneric(VirtualFrame frame) {
}
// Verify the function arity
- if (reduceFunction.getParameterNames().length != 2) {
+ if (reduceFunction.parameterNames.length != 2) {
throw LKQLRuntimeException.fromMessage(
"Function passed to reduce should have arity of two",
this.callNode.getArgList().getArgs()[1]);
@@ -108,7 +108,7 @@ public Object executeGeneric(VirtualFrame frame) {
initValue =
this.interopLibrary.execute(
reduceFunction,
- reduceFunction.getClosure().getContent(),
+ reduceFunction.closure.getContent(),
initValue,
iterator.next());
} catch (ArityException
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/UnitCheckerFunction.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/UnitCheckerFunction.java
index fc568d0d8..8226d62a7 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/UnitCheckerFunction.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/UnitCheckerFunction.java
@@ -159,10 +159,10 @@ private void applyUnitRule(
final String lowerRuleName = StringUtils.toLowerCase(checker.getName());
// Prepare the arguments
- Object[] arguments = new Object[functionValue.getParameterNames().length + 1];
+ Object[] arguments = new Object[functionValue.parameterNames.length + 1];
arguments[1] = unit;
- for (int i = 1; i < functionValue.getParameterDefaultValues().length; i++) {
- String paramName = functionValue.getParameterNames()[i];
+ for (int i = 1; i < functionValue.parameterDefaultValues.length; i++) {
+ String paramName = functionValue.parameterNames[i];
Object userDefinedArg =
context.getRuleArg(
(aliasName == null
@@ -171,12 +171,12 @@ private void applyUnitRule(
paramName);
arguments[i + 1] =
userDefinedArg == null
- ? functionValue.getParameterDefaultValues()[i].executeGeneric(frame)
+ ? functionValue.parameterDefaultValues[i].executeGeneric(frame)
: userDefinedArg;
}
// Put the closure in the arguments
- arguments[0] = functionValue.getClosure().getContent();
+ arguments[0] = functionValue.closure.getContent();
// Get the message list from the checker function
final Iterable violationList;
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/AnalysisUnitMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/AnalysisUnitMethods.java
index 0543b0c09..711e94bbe 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/AnalysisUnitMethods.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/AnalysisUnitMethods.java
@@ -22,6 +22,8 @@
package com.adacore.lkql_jit.built_ins.methods;
+import static com.adacore.lkql_jit.built_ins.BuiltInFunctionValue.create;
+
import com.adacore.libadalang.Libadalang;
import com.adacore.lkql_jit.LKQLTypeSystemGen;
import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
@@ -29,91 +31,43 @@
import com.adacore.lkql_jit.built_ins.values.LKQLNull;
import com.adacore.lkql_jit.built_ins.values.lists.LKQLList;
import com.adacore.lkql_jit.nodes.expressions.Expr;
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
import com.oracle.truffle.api.frame.VirtualFrame;
import java.util.ArrayList;
+import java.util.Map;
/**
* This class contains all built-in methods for the analysis unit type in the LKQL language.
*
* @author Hugo GUERRIER
*/
-public final class AnalysisUnitMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static AnalysisUnitMethods instance;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private AnalysisUnitMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the analysis unit method.
- */
- public static AnalysisUnitMethods getInstance() {
- if (instance == null) {
- instance = new AnalysisUnitMethods();
- }
- return instance;
- }
-
- /**
- * @see CommonMethods#initMethods()
- */
- @Override
- protected void initMethods() {
- super.initMethods();
-
- this.methods.put(
- "root",
- new BuiltInFunctionValue(
- "root",
- "Return the root for this unit",
- new String[] {"unit"},
- new Expr[] {null},
- new RootExpr()));
- this.methods.put(
- "name",
- new BuiltInFunctionValue(
- "name",
- "Return the name of this unit",
- new String[] {"unit"},
- new Expr[] {null},
- new NameExpr()));
- this.methods.put(
- "tokens",
- new BuiltInFunctionValue(
- "tokens",
- "Return the tokens of the unit",
- new String[] {"unit"},
- new Expr[] {null},
- new TokensExpr()));
- this.methods.put(
- "text",
- new BuiltInFunctionValue(
- "text",
- "Return the text of the analysis unit",
- new String[] {"unit"},
- new Expr[] {null},
- new TextExpr()));
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.ANALYSIS_UNIT;
- }
+public final class AnalysisUnitMethods {
+
+ public static final Map methods =
+ Map.ofEntries(
+ create(
+ "root",
+ "Return the root for this unit",
+ new String[] {"unit"},
+ new Expr[] {null},
+ new RootExpr()),
+ create(
+ "name",
+ "Return the name of this unit",
+ new String[] {"unit"},
+ new Expr[] {null},
+ new NameExpr()),
+ create(
+ "tokens",
+ "Return the tokens of the unit",
+ new String[] {"unit"},
+ new Expr[] {null},
+ new TokensExpr()),
+ create(
+ "text",
+ "Return the text of the analysis unit",
+ new String[] {"unit"},
+ new Expr[] {null},
+ new TextExpr()));
// ----- Inner classes -----
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/BoolMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/BoolMethods.java
deleted file mode 100644
index 1f5309e01..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/BoolMethods.java
+++ /dev/null
@@ -1,67 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
-
-/**
- * This class contains all built-in methods for the boolean type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class BoolMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static BoolMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private BoolMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the boolean methods.
- */
- public static BoolMethods getInstance() {
- if (instance == null) {
- instance = new BoolMethods();
- }
- return instance;
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_BOOLEAN;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/BuiltInMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/BuiltInMethods.java
deleted file mode 100644
index e24cb8c6e..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/BuiltInMethods.java
+++ /dev/null
@@ -1,48 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
-import java.util.Map;
-
-/**
- * This interface defines the LKQL built-in methods collections.
- *
- * @author Hugo GUERRIER
- */
-public interface BuiltInMethods {
-
- /**
- * Get the type to attach to the methods.
- *
- * @return The LKQL type in a string.
- */
- String getType();
-
- /**
- * Get the methods to attach to the type.
- *
- * @return The methods for the type.
- */
- Map getMethods();
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/CommonMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/CommonMethods.java
deleted file mode 100644
index 2197b10d8..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/CommonMethods.java
+++ /dev/null
@@ -1,68 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
-import com.adacore.lkql_jit.built_ins.functions.*;
-import java.util.HashMap;
-import java.util.Map;
-
-/**
- * This class contains the common built-in methods for all type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public abstract class CommonMethods implements BuiltInMethods {
-
- // ----- Attributes -----
-
- /** The methods map from their names to their function values. */
- protected final Map methods;
-
- // ----- Constructors -----
-
- /** Create the common methods for all type. */
- protected CommonMethods() {
- this.methods = new HashMap<>();
- this.initMethods();
- }
-
- /** Initialize the common methods. */
- protected void initMethods() {
- this.methods.put(ImgFunction.NAME, ImgFunction.getValue());
- this.methods.put(PrintFunction.NAME, PrintFunction.getValue());
- this.methods.put(DocFunction.NAME, DocFunction.getValue());
- this.methods.put(ProfileFunction.NAME, ProfileFunction.getValue());
- this.methods.put(HelpFunction.NAME, HelpFunction.getValue());
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getMethods()
- */
- @Override
- public Map getMethods() {
- return this.methods;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/FunctionMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/FunctionMethods.java
deleted file mode 100644
index a11d1bfaf..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/FunctionMethods.java
+++ /dev/null
@@ -1,67 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
-
-/**
- * This class contains all built-in methods for the function type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class FunctionMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static FunctionMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private FunctionMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the function methods.
- */
- public static FunctionMethods getInstance() {
- if (instance == null) {
- instance = new FunctionMethods();
- }
- return instance;
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_FUNCTION;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/IterableMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/IterableMethods.java
index 177bdedeb..3d36020be 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/IterableMethods.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/IterableMethods.java
@@ -22,6 +22,8 @@
package com.adacore.lkql_jit.built_ins.methods;
+import static com.adacore.lkql_jit.built_ins.BuiltInFunctionValue.create;
+
import com.adacore.lkql_jit.LKQLTypeSystemGen;
import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
import com.adacore.lkql_jit.built_ins.BuiltinFunctionBody;
@@ -33,39 +35,30 @@
import com.oracle.truffle.api.frame.VirtualFrame;
import java.util.LinkedList;
import java.util.List;
+import java.util.Map;
/**
* This class contains all built-in methods for the iterable type in the LKQL language.
*
* @author Hugo GUERRIER
*/
-public abstract class IterableMethods extends CommonMethods {
-
- /**
- * @see CommonMethods#initMethods()
- */
- @Override
- protected void initMethods() {
- super.initMethods();
+public class IterableMethods {
- this.methods.put(ReduceFunction.NAME, ReduceFunction.getValue());
- this.methods.put(
- "to_list",
- new BuiltInFunctionValue(
- "to_list",
- "Transform an iterator into a list",
- new String[] {"iterable"},
- new Expr[] {null},
- new ToListExpr()));
- this.methods.put(
- "length",
- new BuiltInFunctionValue(
- "length",
- "Get the length of the iterable element",
- new String[] {"iterable"},
- new Expr[] {null},
- new LengthExpr()));
- }
+ public static final Map methods =
+ Map.ofEntries(
+ Map.entry(ReduceFunction.NAME, ReduceFunction.getValue()),
+ create(
+ "to_list",
+ "Transform an iterator into a list",
+ new String[] {"iterable"},
+ new Expr[] {null},
+ new ToListExpr()),
+ create(
+ "length",
+ "Get the length of the iterable element",
+ new String[] {"iterable"},
+ new Expr[] {null},
+ new LengthExpr()));
// ----- Inner classes -----
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/LazyListMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/LazyListMethods.java
deleted file mode 100644
index d85e36814..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/LazyListMethods.java
+++ /dev/null
@@ -1,67 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
-
-/**
- * This class contains all built-in methods for the lazy list type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class LazyListMethods extends IterableMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static LazyListMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private LazyListMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the lazy list methods.
- */
- public static LazyListMethods getInstance() {
- if (instance == null) {
- instance = new LazyListMethods();
- }
- return instance;
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_LAZY_LIST;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/ListMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/ListMethods.java
index c6eec3661..2c932616e 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/ListMethods.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/ListMethods.java
@@ -22,8 +22,11 @@
package com.adacore.lkql_jit.built_ins.methods;
+import static com.adacore.lkql_jit.built_ins.BuiltInFunctionValue.create;
+
import com.adacore.lkql_jit.LKQLTypeSystemGen;
import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
+import com.adacore.lkql_jit.built_ins.BuiltInsHolder;
import com.adacore.lkql_jit.built_ins.functions.UniqueFunction;
import com.adacore.lkql_jit.built_ins.values.lists.LKQLList;
import com.adacore.lkql_jit.exception.LKQLRuntimeException;
@@ -32,101 +35,64 @@
import com.adacore.lkql_jit.utils.LKQLTypesHelper;
import com.oracle.truffle.api.frame.VirtualFrame;
import java.util.Arrays;
+import java.util.Map;
/**
* This class contains all built-in methods for the list type in the LKQL language.
*
* @author Hugo GUERRIER
*/
-public final class ListMethods extends IterableMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static ListMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor */
- private ListMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the list methods.
- */
- public static ListMethods getInstance() {
- if (instance == null) {
- instance = new ListMethods();
- }
- return instance;
- }
-
- /**
- * @see CommonMethods#initMethods()
- */
- @Override
- protected void initMethods() {
- super.initMethods();
- this.methods.put(UniqueFunction.NAME, UniqueFunction.getValue());
- this.methods.put(
- "sublist",
- new BuiltInFunctionValue(
- "sublist",
- "Return a sublist of `list` from `low_bound` to `high_bound`",
- new String[] {"list", "low_bound", "high_bound"},
- new Expr[] {null, null, null},
- (VirtualFrame frame, FunCall call) -> {
- var args = frame.getArguments();
-
- if (!LKQLTypeSystemGen.isLKQLList(args[0])) {
- throw LKQLRuntimeException.wrongType(
- LKQLTypesHelper.LKQL_LIST,
- LKQLTypesHelper.fromJava(args[0]),
- call.getArgList().getArgs()[0]);
- }
-
- if (!LKQLTypeSystemGen.isLong(args[1])) {
- throw LKQLRuntimeException.wrongType(
- LKQLTypesHelper.LKQL_INTEGER,
- LKQLTypesHelper.fromJava(args[1]),
- call.getArgList().getArgs()[1]);
- }
-
- if (!LKQLTypeSystemGen.isLong(args[2])) {
- throw LKQLRuntimeException.wrongType(
- LKQLTypesHelper.LKQL_INTEGER,
- LKQLTypesHelper.fromJava(args[2]),
- call.getArgList().getArgs()[2]);
- }
-
- LKQLList list = LKQLTypeSystemGen.asLKQLList(args[0]);
- long lowBound = LKQLTypeSystemGen.asLong(args[1]);
- long highBound = LKQLTypeSystemGen.asLong(args[2]);
-
- if (lowBound < 1) {
- throw LKQLRuntimeException.invalidIndex((int) lowBound, call);
- } else if (highBound > list.getContent().length) {
- throw LKQLRuntimeException.invalidIndex((int) highBound, call);
- }
-
- return new LKQLList(
- Arrays.copyOfRange(
- list.getContent(),
- (int) lowBound - 1,
- (int) highBound));
- }));
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_LIST;
- }
+public class ListMethods {
+
+ private static final Map.Entry sublistFunction =
+ create(
+ "sublist",
+ "Return a sublist of `list` from `low_bound` to `high_bound`",
+ new String[] {"list", "low_bound", "high_bound"},
+ new Expr[] {null, null, null},
+ (VirtualFrame frame, FunCall call) -> {
+ var args = frame.getArguments();
+
+ if (!LKQLTypeSystemGen.isLKQLList(args[0])) {
+ throw LKQLRuntimeException.wrongType(
+ LKQLTypesHelper.LKQL_LIST,
+ LKQLTypesHelper.fromJava(args[0]),
+ call.getArgList().getArgs()[0]);
+ }
+
+ if (!LKQLTypeSystemGen.isLong(args[1])) {
+ throw LKQLRuntimeException.wrongType(
+ LKQLTypesHelper.LKQL_INTEGER,
+ LKQLTypesHelper.fromJava(args[1]),
+ call.getArgList().getArgs()[1]);
+ }
+
+ if (!LKQLTypeSystemGen.isLong(args[2])) {
+ throw LKQLRuntimeException.wrongType(
+ LKQLTypesHelper.LKQL_INTEGER,
+ LKQLTypesHelper.fromJava(args[2]),
+ call.getArgList().getArgs()[2]);
+ }
+
+ LKQLList list = LKQLTypeSystemGen.asLKQLList(args[0]);
+ long lowBound = LKQLTypeSystemGen.asLong(args[1]);
+ long highBound = LKQLTypeSystemGen.asLong(args[2]);
+
+ if (lowBound < 1) {
+ throw LKQLRuntimeException.invalidIndex((int) lowBound, call);
+ } else if (highBound > list.getContent().length) {
+ throw LKQLRuntimeException.invalidIndex((int) highBound, call);
+ }
+
+ return new LKQLList(
+ Arrays.copyOfRange(
+ list.getContent(), (int) lowBound - 1, (int) highBound));
+ });
+
+ public static final Map methods =
+ BuiltInsHolder.combine(
+ Map.ofEntries(
+ Map.entry(UniqueFunction.NAME, UniqueFunction.getValue()),
+ sublistFunction),
+ IterableMethods.methods);
}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/NamespaceMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/NamespaceMethods.java
deleted file mode 100644
index a6ac3ff6a..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/NamespaceMethods.java
+++ /dev/null
@@ -1,67 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
-
-/**
- * This class contains all built-in methods for the namespace type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class NamespaceMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static NamespaceMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private NamespaceMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the namespace methods.
- */
- public static NamespaceMethods getInstance() {
- if (instance == null) {
- instance = new NamespaceMethods();
- }
- return instance;
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_NAMESPACE;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/NodeMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/NodeMethods.java
index 1ccc87556..3926a54f0 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/NodeMethods.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/NodeMethods.java
@@ -22,6 +22,8 @@
package com.adacore.lkql_jit.built_ins.methods;
+import static com.adacore.lkql_jit.built_ins.BuiltInFunctionValue.create;
+
import com.adacore.libadalang.Libadalang;
import com.adacore.lkql_jit.LKQLLanguage;
import com.adacore.lkql_jit.LKQLTypeSystemGen;
@@ -39,137 +41,77 @@
import com.oracle.truffle.api.frame.VirtualFrame;
import com.oracle.truffle.api.nodes.UnexpectedResultException;
import java.util.ArrayList;
+import java.util.Map;
/**
* This class contains all built-in methods for the node type in the LKQL language.
*
* @author Hugo GUERRIER
*/
-public final class NodeMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static NodeMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructors. */
- private NodeMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the node methods.
- */
- public static NodeMethods getInstance() {
- if (instance == null) {
- instance = new NodeMethods();
- }
- return instance;
- }
-
- /**
- * @see CommonMethods#initMethods()
- */
- @Override
- protected void initMethods() {
- super.initMethods();
- this.methods.put(
- "children_count",
- new BuiltInFunctionValue(
- "children_count",
- "Given a node, return the count of its children",
- new String[] {"node"},
- new Expr[] {null},
- new ChildrenCountExpr()));
- this.methods.put(
- "children",
- new BuiltInFunctionValue(
- "children",
- "Given a node, get the list of all its children",
- new String[] {"node"},
- new Expr[] {null},
- new ChildrenExpr()));
- this.methods.put(
- "parent",
- new BuiltInFunctionValue(
- "parent",
- "Given a node, get the parent of it",
- new String[] {"node"},
- new Expr[] {null},
- new ParentExpr()));
- this.methods.put(
- "dump",
- new BuiltInFunctionValue(
- "dump",
- "Given an ast node, return a structured dump of the subtree",
- new String[] {"node"},
- new Expr[] {null},
- new DumpExpr()));
- this.methods.put(
- "text",
- new BuiltInFunctionValue(
- "text",
- "Given an ast node, return its text",
- new String[] {"node"},
- new Expr[] {null},
- new TextExpr()));
- this.methods.put(
- "image",
- new BuiltInFunctionValue(
- "image",
- "Given an ast node, return its image",
- new String[] {"node"},
- new Expr[] {null},
- new ImageExpr()));
- this.methods.put(
- "unit",
- new BuiltInFunctionValue(
- "unit",
- "Given an ast node, return its analysis unit",
- new String[] {"node"},
- new Expr[] {null},
- new UnitExpr()));
- this.methods.put(
- "kind",
- new BuiltInFunctionValue(
- "kind",
- "Return the kind of this node, as a string",
- new String[] {"node"},
- new Expr[] {null},
- new KindExpr()));
- this.methods.put(
- "tokens",
- new BuiltInFunctionValue(
- "tokens",
- "Given a node, return an iterator on its tokens",
- new String[] {"node"},
- new Expr[] {null},
- new TokensExpr()));
- this.methods.put(
- "same_tokens",
- new BuiltInFunctionValue(
- "same_tokens",
- "Return whether two nodes have the same tokens, ignoring trivias",
- new String[] {"node", "other"},
- new Expr[] {null, null},
- new SameTokensExpr()));
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.ADA_NODE;
- }
-
- // ----- Inner classes -----
+public final class NodeMethods {
+
+ public static final Map methods =
+ Map.ofEntries(
+ create(
+ "children_count",
+ "Given a node, return the count of its children",
+ new String[] {"node"},
+ new Expr[] {null},
+ new ChildrenCountExpr()),
+ create(
+ "children",
+ "Given a node, get the list of all its children",
+ new String[] {"node"},
+ new Expr[] {null},
+ new ChildrenExpr()),
+ create(
+ "parent",
+ "Given a node, get the parent of it",
+ new String[] {"node"},
+ new Expr[] {null},
+ new ParentExpr()),
+ create(
+ "dump",
+ "Given an ast node, return a structured dump of the subtree",
+ new String[] {"node"},
+ new Expr[] {null},
+ new DumpExpr()),
+ create(
+ "text",
+ "Given an ast node, return its text",
+ new String[] {"node"},
+ new Expr[] {null},
+ new TextExpr()),
+ create(
+ "image",
+ "Given an ast node, return its image",
+ new String[] {"node"},
+ new Expr[] {null},
+ new ImageExpr()),
+ create(
+ "unit",
+ "Given an ast node, return its analysis unit",
+ new String[] {"node"},
+ new Expr[] {null},
+ new UnitExpr()),
+ create(
+ "kind",
+ "Return the kind of this node, as a string",
+ new String[] {"node"},
+ new Expr[] {null},
+ new KindExpr()),
+ create(
+ "tokens",
+ "Given a node, return an iterator on its tokens",
+ new String[] {"node"},
+ new Expr[] {null},
+ new TokensExpr()),
+ create(
+ "same_tokens",
+ "Return whether two nodes have the same tokens, ignoring trivias",
+ new String[] {"node", "other"},
+ new Expr[] {null, null},
+ new SameTokensExpr()));
/** Expression of the "children" method. */
public static final class ChildrenExpr extends BuiltinFunctionBody {
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/ObjectMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/ObjectMethods.java
deleted file mode 100644
index 0f4b7d388..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/ObjectMethods.java
+++ /dev/null
@@ -1,67 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
-
-/**
- * This class contains all built-in methods for the object type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class ObjectMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static ObjectMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private ObjectMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the object methods.
- */
- public static ObjectMethods getInstance() {
- if (instance == null) {
- instance = new ObjectMethods();
- }
- return instance;
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_OBJECT;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/PropertyRefMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/PropertyRefMethods.java
deleted file mode 100644
index 69147a473..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/PropertyRefMethods.java
+++ /dev/null
@@ -1,67 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
-
-/**
- * This class contains all built-in methods for the property reference type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class PropertyRefMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static PropertyRefMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private PropertyRefMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the property reference methods.
- */
- public static PropertyRefMethods getInstance() {
- if (instance == null) {
- instance = new PropertyRefMethods();
- }
- return instance;
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_PROPERTY_REF;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/SelectorListMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/SelectorListMethods.java
deleted file mode 100644
index e060fcb36..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/SelectorListMethods.java
+++ /dev/null
@@ -1,67 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
-
-/**
- * This class contains all built-in methods for the selector list type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class SelectorListMethods extends IterableMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static SelectorListMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private SelectorListMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the selector list methods.
- */
- public static SelectorListMethods getInstance() {
- if (instance == null) {
- instance = new SelectorListMethods();
- }
- return instance;
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_SELECTOR_LIST;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/SelectorMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/SelectorMethods.java
deleted file mode 100644
index 18fdce872..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/SelectorMethods.java
+++ /dev/null
@@ -1,67 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
-
-/**
- * This class contains all built-in methods for the selector type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class SelectorMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static SelectorMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private SelectorMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the selector methods.
- */
- public static SelectorMethods getInstance() {
- if (instance == null) {
- instance = new SelectorMethods();
- }
- return instance;
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_SELECTOR;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/StrMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/StrMethods.java
index 951db28d4..dd987978c 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/StrMethods.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/StrMethods.java
@@ -22,6 +22,8 @@
package com.adacore.lkql_jit.built_ins.methods;
+import static com.adacore.lkql_jit.built_ins.BuiltInFunctionValue.create;
+
import com.adacore.lkql_jit.LKQLTypeSystemGen;
import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
import com.adacore.lkql_jit.built_ins.BuiltinFunctionBody;
@@ -35,158 +37,96 @@
import com.adacore.lkql_jit.utils.functions.StringUtils;
import com.oracle.truffle.api.frame.VirtualFrame;
import java.math.BigInteger;
+import java.util.Map;
/**
* This class contains all built-in methods for the string type in the LKQL language.
*
* @author Hugo GUERRIER
*/
-public final class StrMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static StrMethods instance = null;
-
- // ----- Constructors -----
-
- /** Create the methods for the string type. */
- private StrMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the string methods.
- */
- public static StrMethods getInstance() {
- if (instance == null) {
- instance = new StrMethods();
- }
- return instance;
- }
-
- /**
- * @see CommonMethods#initMethods()
- */
- @Override
- protected void initMethods() {
- super.initMethods();
- this.methods.put(BaseNameFunction.NAME, BaseNameFunction.getValue());
- this.methods.put(
- "to_lower_case",
- new BuiltInFunctionValue(
- "to_lower_case",
- "Return the given string written with lower case characters only",
- new String[] {"str"},
- new Expr[] {null},
- new ToLowerCaseExpr()));
- this.methods.put(
- "is_lower_case",
- new BuiltInFunctionValue(
- "is_lower_case",
- "Return whether the given string contains lower case characters only",
- new String[] {"str"},
- new Expr[] {null},
- new IsLowerCaseExpr()));
- this.methods.put(
- "to_upper_case",
- new BuiltInFunctionValue(
- "to_upper_case",
- "Return the given string written with upper case characters only",
- new String[] {"str"},
- new Expr[] {null},
- new ToUpperCaseExpr()));
- this.methods.put(
- "is_upper_case",
- new BuiltInFunctionValue(
- "is_upper_case",
- "Return whether the given string contains upper case characters only",
- new String[] {"str"},
- new Expr[] {null},
- new IsUpperCaseExpr()));
- this.methods.put(
- "is_mixed_case",
- new BuiltInFunctionValue(
- "is_mixed_case",
- "Return whether the given string is written in mixed case, that is, with"
- + " only lower case characters except the first one and every character"
- + " following an underscore",
- new String[] {"str"},
- new Expr[] {null},
- new IsMixedCaseExpr()));
- this.methods.put(
- "length",
- new BuiltInFunctionValue(
- "length",
- "Given a string, return the length of it in character",
- new String[] {"str"},
- new Expr[] {null},
- new LengthExpr()));
- this.methods.put(
- "substring",
- new BuiltInFunctionValue(
- "substring",
- "Given a string and two indices (from and to), return the substring"
- + " contained between indices from and to (both included)",
- new String[] {"str", "from", "to"},
- new Expr[] {null, null, null},
- new SubstringExpr()));
- this.methods.put(
- "split",
- new BuiltInFunctionValue(
- "split",
- "Given a string, return an iterator on the words contained by str separated"
- + " by separator",
- new String[] {"str", "separator"},
- new Expr[] {null, null},
- new SplitExpr()));
- this.methods.put(
- "contains",
- new BuiltInFunctionValue(
- "contains",
- "Search for to_find in the given string. Return whether a match is found."
- + " to_find can be either a pattern or a string",
- new String[] {"str", "to_find"},
- new Expr[] {null, null},
- new ContainsExpr()));
- this.methods.put(
- "find",
- new BuiltInFunctionValue(
- "find",
- "Search for to_find in the given string. Return position of the match, or"
- + " -1 if no match. to_find can be either a pattern or a string",
- new String[] {"str", "to_find"},
- new Expr[] {null, null},
- new FindExpr()));
- this.methods.put(
- "starts_with",
- new BuiltInFunctionValue(
- "starts_with",
- "Given a string, returns whether it starts with the given prefix",
- new String[] {"str", "prefix"},
- new Expr[] {null, null},
- new StartsWithExpr()));
- this.methods.put(
- "ends_with",
- new BuiltInFunctionValue(
- "ends_with",
- "Given a string, returns whether it ends with the given suffix",
- new String[] {"str", "suffix"},
- new Expr[] {null, null},
- new EndsWithExpr()));
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_STRING;
- }
+public class StrMethods {
+
+ public static final Map methods =
+ Map.ofEntries(
+ Map.entry(BaseNameFunction.NAME, BaseNameFunction.getValue()),
+ create(
+ "to_lower_case",
+ "Return the given string written with lower case characters only",
+ new String[] {"str"},
+ new Expr[] {null},
+ new ToLowerCaseExpr()),
+ create(
+ "is_lower_case",
+ "Return whether the given string contains lower case characters only",
+ new String[] {"str"},
+ new Expr[] {null},
+ new IsLowerCaseExpr()),
+ create(
+ "to_upper_case",
+ "Return the given string written with upper case characters only",
+ new String[] {"str"},
+ new Expr[] {null},
+ new ToUpperCaseExpr()),
+ create(
+ "is_upper_case",
+ "Return whether the given string contains upper case characters only",
+ new String[] {"str"},
+ new Expr[] {null},
+ new IsUpperCaseExpr()),
+ create(
+ "is_mixed_case",
+ "Return whether the given string is written in mixed case, that is,"
+ + " with only lower case characters except the first one and every"
+ + " character following an underscore",
+ new String[] {"str"},
+ new Expr[] {null},
+ new IsMixedCaseExpr()),
+ create(
+ "length",
+ "Given a string, return the length of it in character",
+ new String[] {"str"},
+ new Expr[] {null},
+ new LengthExpr()),
+ create(
+ "substring",
+ "Given a string and two indices (from and to), return the substring"
+ + " contained between indices from and to (both included)",
+ new String[] {"str", "from", "to"},
+ new Expr[] {null, null, null},
+ new SubstringExpr()),
+ create(
+ "split",
+ "Given a string, return an iterator on the words contained by str"
+ + " separated by separator",
+ new String[] {"str", "separator"},
+ new Expr[] {null, null},
+ new SplitExpr()),
+ create(
+ "contains",
+ "Search for to_find in the given string. Return whether a match is"
+ + " found. to_find can be either a pattern or a string",
+ new String[] {"str", "to_find"},
+ new Expr[] {null, null},
+ new ContainsExpr()),
+ create(
+ "find",
+ "Search for to_find in the given string. Return position of the match,"
+ + " or -1 if no match. to_find can be either a pattern or a string",
+ new String[] {"str", "to_find"},
+ new Expr[] {null, null},
+ new FindExpr()),
+ create(
+ "starts_with",
+ "Given a string, returns whether it starts with the given prefix",
+ new String[] {"str", "prefix"},
+ new Expr[] {null, null},
+ new StartsWithExpr()),
+ create(
+ "ends_with",
+ "Given a string, returns whether it ends with the given suffix",
+ new String[] {"str", "suffix"},
+ new Expr[] {null, null},
+ new EndsWithExpr()));
// ----- Inner classes -----
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/TokenMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/TokenMethods.java
index 9cd8ffb2c..8718704f4 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/TokenMethods.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/TokenMethods.java
@@ -22,6 +22,8 @@
package com.adacore.lkql_jit.built_ins.methods;
+import static com.adacore.lkql_jit.built_ins.BuiltInFunctionValue.create;
+
import com.adacore.libadalang.Libadalang;
import com.adacore.lkql_jit.LKQLTypeSystemGen;
import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
@@ -34,143 +36,83 @@
import com.adacore.lkql_jit.utils.functions.StringUtils;
import com.oracle.truffle.api.frame.VirtualFrame;
import com.oracle.truffle.api.nodes.UnexpectedResultException;
+import java.util.Map;
/**
* This class contains all built-in methods for the token type in the LKQL language.
*
* @author Hugo GUERRIER
*/
-public final class TokenMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static TokenMethods instance = null;
-
- // ----- Constructors -----
+public final class TokenMethods {
- /** Private constructor. */
- private TokenMethods() {
- super();
- }
-
- /**
- * Get the only instance of the token method library.
- *
- * @return The instance of the token methods.
- */
- public static TokenMethods getInstance() {
- if (instance == null) {
- instance = new TokenMethods();
- }
- return instance;
- }
-
- /**
- * @see CommonMethods#initMethods()
- */
- @Override
- protected void initMethods() {
- super.initMethods();
- this.methods.put(
- "start_column",
- new BuiltInFunctionValue(
- "start_column",
- "Return the column start",
- new String[] {"token"},
- new Expr[] {null},
- new StartColExpr()));
- this.methods.put(
- "end_column",
- new BuiltInFunctionValue(
- "end_column",
- "Return the column end",
- new String[] {"token"},
- new Expr[] {null},
- new EndColExpr()));
- this.methods.put(
- "start_line",
- new BuiltInFunctionValue(
- "start_line",
- "Return the line start",
- new String[] {"token"},
- new Expr[] {null},
- new StartLineExpr()));
- this.methods.put(
- "end_line",
- new BuiltInFunctionValue(
- "end_line",
- "Return the line end",
- new String[] {"token"},
- new Expr[] {null},
- new EndLineExpr()));
- this.methods.put(
- "is_equivalent",
- new BuiltInFunctionValue(
- "is_equivalent",
- "Return whether two tokens are structurally equivalent",
- new String[] {"this", "other"},
- new Expr[] {null, null},
- new IsEquivalentExpr()));
- this.methods.put(
- "is_trivia",
- new BuiltInFunctionValue(
- "is_trivia",
- "Return whether this token is a trivia",
- new String[] {"token"},
- new Expr[] {null},
- new IsTriviaExpr()));
- this.methods.put(
- "next",
- new BuiltInFunctionValue(
- "next",
- "Return the next token",
- new String[] {"token", "exclude_trivia"},
- new Expr[] {null, new BooleanLiteral(null, false)},
- new NextExpr()));
- this.methods.put(
- "previous",
- new BuiltInFunctionValue(
- "previous",
- "Return the previous token",
- new String[] {"token", "exclude_trivia"},
- new Expr[] {null, new BooleanLiteral(null, false)},
- new PrevExpr()));
- this.methods.put(
- "unit",
- new BuiltInFunctionValue(
- "unit",
- "Return the unit for this token",
- new String[] {"token"},
- new Expr[] {null},
- new UnitExpr()));
- this.methods.put(
- "text",
- new BuiltInFunctionValue(
- "text",
- "Return the text of the token",
- new String[] {"token"},
- new Expr[] {null},
- new TextExpr()));
- this.methods.put(
- "kind",
- new BuiltInFunctionValue(
- "kind",
- "Return the kind of the token",
- new String[] {"token"},
- new Expr[] {null},
- new KindExpr()));
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.TOKEN;
- }
+ public static final Map methods =
+ Map.ofEntries(
+ create(
+ "start_column",
+ "Return the column start",
+ new String[] {"token"},
+ new Expr[] {null},
+ new StartColExpr()),
+ create(
+ "end_column",
+ "Return the column end",
+ new String[] {"token"},
+ new Expr[] {null},
+ new EndColExpr()),
+ create(
+ "start_line",
+ "Return the line start",
+ new String[] {"token"},
+ new Expr[] {null},
+ new StartLineExpr()),
+ create(
+ "end_line",
+ "Return the line end",
+ new String[] {"token"},
+ new Expr[] {null},
+ new EndLineExpr()),
+ create(
+ "is_equivalent",
+ "Return whether two tokens are structurally equivalent",
+ new String[] {"this", "other"},
+ new Expr[] {null, null},
+ new IsEquivalentExpr()),
+ create(
+ "is_trivia",
+ "Return whether this token is a trivia",
+ new String[] {"token"},
+ new Expr[] {null},
+ new IsTriviaExpr()),
+ create(
+ "next",
+ "Return the next token",
+ new String[] {"token", "exclude_trivia"},
+ new Expr[] {null, new BooleanLiteral(null, false)},
+ new NextExpr()),
+ create(
+ "previous",
+ "Return the previous token",
+ new String[] {"token", "exclude_trivia"},
+ new Expr[] {null, new BooleanLiteral(null, false)},
+ new PrevExpr()),
+ create(
+ "unit",
+ "Return the unit for this token",
+ new String[] {"token"},
+ new Expr[] {null},
+ new UnitExpr()),
+ create(
+ "text",
+ "Return the text of the token",
+ new String[] {"token"},
+ new Expr[] {null},
+ new TextExpr()),
+ create(
+ "kind",
+ "Return the kind of the token",
+ new String[] {"token"},
+ new Expr[] {null},
+ new KindExpr()));
// ----- Inner classes -----
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/TupleMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/TupleMethods.java
deleted file mode 100644
index ac83893f6..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/TupleMethods.java
+++ /dev/null
@@ -1,67 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
-
-/**
- * This class contains all built-in methods for the tuple type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class TupleMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static TupleMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private TupleMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the tuple methods.
- */
- public static TupleMethods getInstance() {
- if (instance == null) {
- instance = new TupleMethods();
- }
- return instance;
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_TUPLE;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/UnitMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/UnitMethods.java
deleted file mode 100644
index 7028202ef..000000000
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/UnitMethods.java
+++ /dev/null
@@ -1,67 +0,0 @@
-/*----------------------------------------------------------------------------
--- L K Q L J I T --
--- --
--- Copyright (C) 2022-2023, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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 --
--- --
-----------------------------------------------------------------------------*/
-
-package com.adacore.lkql_jit.built_ins.methods;
-
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
-
-/**
- * This class contains all built-in methods for the unit type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class UnitMethods extends CommonMethods {
-
- // ----- Attributes -----
-
- /** The only instance of the method collection. */
- private static UnitMethods instance = null;
-
- // ----- Constructors -----
-
- /** Private constructor. */
- private UnitMethods() {
- super();
- }
-
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the unit methods.
- */
- public static UnitMethods getInstance() {
- if (instance == null) {
- instance = new UnitMethods();
- }
- return instance;
- }
-
- // ----- Override methods -----
-
- /**
- * @see BuiltInMethods#getType()
- */
- @Override
- public String getType() {
- return LKQLTypesHelper.LKQL_UNIT;
- }
-}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLFunction.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLFunction.java
index 479dab521..e6b1f2971 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLFunction.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLFunction.java
@@ -37,6 +37,7 @@
import com.oracle.truffle.api.nodes.DirectCallNode;
import com.oracle.truffle.api.nodes.IndirectCallNode;
import com.oracle.truffle.api.utilities.TriState;
+import java.util.ArrayList;
/** This class represents the function values in LKQL. */
@ExportLibrary(InteropLibrary.class)
@@ -45,25 +46,25 @@ public class LKQLFunction extends BasicLKQLValue {
// ----- Attributes -----
/** The root node representing the function body. */
- private final FunctionRootNode rootNode;
+ public final FunctionRootNode rootNode;
- /** The closure for the function exercution. */
- private final Closure closure;
+ /** The closure for the function execution. */
+ public final Closure closure;
/** The name of the function. */
- @CompilerDirectives.CompilationFinal private String name;
+ @CompilerDirectives.CompilationFinal public String name;
/** The documentation of the function. */
- private final String documentation;
+ public final String documentation;
/** Names of the function parameters. */
- private final String[] parameterNames;
+ public final String[] parameterNames;
/**
* Default values of the function parameters (if a function parameter doesn't have any, the
* value is 'null').
*/
- private final Expr[] parameterDefaultValues;
+ public final Expr[] parameterDefaultValues;
// ----- Constructors -----
@@ -94,26 +95,10 @@ public LKQLFunction(
// ----- Getters ------
- public FunctionRootNode getRootNode() {
- return rootNode;
- }
-
- public Closure getClosure() {
- return closure;
- }
-
public String getName() {
return name;
}
- public String[] getParameterNames() {
- return parameterNames;
- }
-
- public Expr[] getParameterDefaultValues() {
- return parameterDefaultValues;
- }
-
// ----- Setters -----
public void setName(String name) {
@@ -215,4 +200,19 @@ public Object getExecutableName() {
public String lkqlDocumentation() {
return this.documentation;
}
+
+ @Override
+ @CompilerDirectives.TruffleBoundary
+ public String lkqlProfile() {
+ var expandedParams = new ArrayList();
+ for (int i = 0; i < parameterNames.length; i++) {
+ var defVal = parameterDefaultValues[i];
+ if (defVal != null) {
+ expandedParams.add(parameterNames[i] + "=" + defVal.getLocation().getText());
+ } else {
+ expandedParams.add(parameterNames[i]);
+ }
+ }
+ return name + "(" + String.join(", ", expandedParams.toArray(new String[0])) + ")";
+ }
}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLNamespace.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLNamespace.java
index cbd4cc8be..6b8a232d9 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLNamespace.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLNamespace.java
@@ -46,18 +46,21 @@
@ExportLibrary(InteropLibrary.class)
public class LKQLNamespace extends ObjectLKQLValue implements LKQLValue {
+ public final String documentation;
+
// ----- Constructors -----
/** Create a new LKQL namespace with its shape. */
- public LKQLNamespace(Shape shape) {
+ public LKQLNamespace(Shape shape, String documentation) {
super(shape);
+ this.documentation = documentation;
}
// ----- Class methods -----
/** Create a namespace from the given Truffle frame and its store values. */
@CompilerDirectives.TruffleBoundary
- public static LKQLNamespace createUncached(MaterializedFrame frame) {
+ public static LKQLNamespace createUncached(MaterializedFrame frame, String doc) {
// Prepare the map for the symbols
final Map symbols = new HashMap<>();
@@ -71,7 +74,7 @@ public static LKQLNamespace createUncached(MaterializedFrame frame) {
}
// Return the new namespace
- LKQLNamespace res = new LKQLNamespace(Shape.newBuilder().build());
+ LKQLNamespace res = new LKQLNamespace(Shape.newBuilder().build(), doc);
for (String key : symbols.keySet()) {
uncachedObjectLibrary.put(res, key, symbols.get(key));
}
@@ -155,4 +158,9 @@ Object toDisplayString(
resultBuilder.append(")");
return resultBuilder.toString();
}
+
+ @Override
+ public String lkqlDocumentation() {
+ return this.documentation;
+ }
}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLSelector.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLSelector.java
index d07e52363..855333fb4 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLSelector.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLSelector.java
@@ -151,4 +151,10 @@ public Object execute(Object[] arguments)
public String lkqlDocumentation() {
return this.documentation;
}
+
+ @Override
+ @CompilerDirectives.TruffleBoundary
+ public String lkqlProfile() {
+ return this.name + "()";
+ }
}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/langkit_translator/passes/FramingPass.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/langkit_translator/passes/FramingPass.java
index 384a3ed8c..1e5434fd0 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/langkit_translator/passes/FramingPass.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/langkit_translator/passes/FramingPass.java
@@ -23,7 +23,9 @@
package com.adacore.lkql_jit.langkit_translator.passes;
import com.adacore.liblkqllang.Liblkqllang;
-import com.adacore.lkql_jit.built_ins.BuiltInFactory;
+import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
+import com.adacore.lkql_jit.built_ins.BuiltInsHolder;
+import com.adacore.lkql_jit.built_ins.selectors.BuiltInSelector;
import com.adacore.lkql_jit.exception.LKQLRuntimeException;
import com.adacore.lkql_jit.exception.TranslatorException;
import com.adacore.lkql_jit.langkit_translator.passes.framing_utils.ScriptFramesBuilder;
@@ -141,7 +143,17 @@ public Void visit(Liblkqllang.LkqlNode lkqlNode) {
@Override
public Void visit(Liblkqllang.TopLevelList topLevelList) {
this.scriptFramesBuilder.openFrame(topLevelList);
- BuiltInFactory.getInstance().addBuiltIns(this.scriptFramesBuilder);
+
+ // Add the built-in functions
+ for (BuiltInFunctionValue function : BuiltInsHolder.get().builtInFunctions) {
+ this.scriptFramesBuilder.addBuiltIn(function.getName());
+ }
+
+ // Add the built-in selectors
+ for (BuiltInSelector selector : BuiltInsHolder.get().builtInSelectors) {
+ this.scriptFramesBuilder.addBuiltIn(selector.getName());
+ }
+
this.traverseChildren(topLevelList);
this.scriptFramesBuilder.closeFrame();
return null;
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/langkit_translator/passes/TranslationPass.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/langkit_translator/passes/TranslationPass.java
index 8feebf6a0..bcf86251f 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/langkit_translator/passes/TranslationPass.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/langkit_translator/passes/TranslationPass.java
@@ -130,10 +130,19 @@ private String parseStringLiteral(final Liblkqllang.BaseStringLiteral stringLite
final StringBuilder builder = new StringBuilder();
for (Liblkqllang.LkqlNode subBlock :
((Liblkqllang.BlockStringLiteral) stringLiteral).fDocs().children()) {
- builder.append(StringUtils.translateEscapes(subBlock.getText().substring(2)))
- .append("\n");
+ var str = StringUtils.translateEscapes(subBlock.getText().substring(2));
+
+ if (str.length() > 0) {
+ // First character should be a whitespace, as specified in
+ // the user manual.
+ if (str.charAt(0) != ' ') {
+ throw LKQLRuntimeException.fromMessage(
+ "Invalid blockstring: first character should be whitespace");
+ }
+ builder.append(str.substring(1)).append("\n");
+ }
}
- res = builder.toString().replaceAll("^\\s+", "");
+ res = builder.toString().trim();
}
// Return the result
@@ -197,12 +206,19 @@ public LKQLNode visit(Liblkqllang.TopLevelList topLevelList) {
// Exit the top level frame
this.scriptFrames.exitFrame();
+ String doc = null;
+
+ if (topLevelNodes.size() > 0 && topLevelNodes.get(0) instanceof StringLiteral) {
+ doc = ((StringLiteral) topLevelNodes.get(0)).value;
+ }
+
// Return the top level node
return new TopLevelList(
loc(topLevelList),
this.scriptFrames.getFrameDescriptor(),
topLevelNodes.toArray(new LKQLNode[0]),
- this.source.isInteractive());
+ this.source.isInteractive(),
+ doc);
}
// --- Literals
@@ -1275,6 +1291,8 @@ private FunExpr functionExprHelper(Liblkqllang.BaseFunction baseFunction) {
}
final Expr body = (Expr) baseFunction.fBodyExpr().accept(this);
+ final var docstring = baseFunction.pDoc();
+
// Return the new function expression node
final FunExpr res =
new FunExpr(
@@ -1282,6 +1300,7 @@ private FunExpr functionExprHelper(Liblkqllang.BaseFunction baseFunction) {
this.scriptFrames.getFrameDescriptor(),
this.scriptFrames.getClosureDescriptor(),
parameters.toArray(new ParameterDeclaration[0]),
+ docstring.isNone() ? "" : parseStringLiteral(docstring),
body);
// Exit the function frame
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/TopLevelList.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/TopLevelList.java
index 5bd98e3d3..78de22959 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/TopLevelList.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/TopLevelList.java
@@ -49,6 +49,9 @@ public final class TopLevelList extends LKQLNode {
/** Descriptor of the top level frame. */
private final FrameDescriptor frameDescriptor;
+ /** Documentation for the toplevel list */
+ private final String doc;
+
// ----- Children -----
/** The rule importation nodes. */
@@ -72,11 +75,13 @@ public TopLevelList(
SourceLocation location,
FrameDescriptor frameDescriptor,
LKQLNode[] nodes,
- boolean isInteractive) {
+ boolean isInteractive,
+ String doc) {
super(location);
this.frameDescriptor = frameDescriptor;
this.program = nodes;
this.isInteractive = isInteractive;
+ this.doc = doc;
}
// ----- Getters -----
@@ -103,8 +108,8 @@ public Object executeGeneric(VirtualFrame frame) {
Object val = null;
// Execute the nodes of the program
- for (LKQLNode node : program) {
- val = node.executeGeneric(frame);
+ for (LKQLNode lkqlNode : program) {
+ val = lkqlNode.executeGeneric(frame);
}
// Get the language context and initialize it
@@ -113,11 +118,11 @@ public Object executeGeneric(VirtualFrame frame) {
if (this.isInteractive) {
// In interactive mode, return the last evaluated value, and add the namespace values
// to the global namespace
- this.updateGlobals(LKQLNamespace.createUncached(frame.materialize()));
+ this.updateGlobals(LKQLNamespace.createUncached(frame.materialize(), doc));
return context.getEnv().asGuestValue(val);
} else {
// Else return the namespace corresponding to the program execution
- return LKQLNamespace.createUncached(frame.materialize());
+ return LKQLNamespace.createUncached(frame.materialize(), doc);
}
}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/declarations/FunctionDeclaration.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/declarations/FunctionDeclaration.java
index 480d0e438..9a6c641ae 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/declarations/FunctionDeclaration.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/declarations/FunctionDeclaration.java
@@ -110,7 +110,7 @@ public Object executeGeneric(VirtualFrame frame) {
// Execute the function expression to get the functional value
final LKQLFunction functionValue = this.functionExpression.executeFunction(frame);
functionValue.setName(this.name);
- functionValue.getRootNode().setMemoized(this.isMemoized);
+ functionValue.rootNode.setMemoized(this.isMemoized);
// If the function is a checker, place it in the context
if (this.checkerMode != CheckerMode.OFF) {
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/FunCall.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/FunCall.java
index 7341fca81..7859ccaec 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/FunCall.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/FunCall.java
@@ -117,8 +117,8 @@ protected Object onBuiltIn(
builtIn.setCallNode(this);
// Get the real argument names and default values
- String[] actualParam = builtIn.getParameterNames();
- Expr[] defaultValues = builtIn.getParameterDefaultValues();
+ String[] actualParam = builtIn.parameterNames;
+ Expr[] defaultValues = builtIn.parameterDefaultValues;
// Execute the argument list
// TODO: Do not materialize the frame here, for now we need to do it because of a Truffle
@@ -167,8 +167,8 @@ protected Object onFunction(
final LKQLFunction function,
@CachedLibrary("function") InteropLibrary functionLibrary) {
// Get the real argument names and default values
- String[] names = function.getParameterNames();
- Expr[] defaultValues = function.getParameterDefaultValues();
+ String[] names = function.parameterNames;
+ Expr[] defaultValues = function.parameterDefaultValues;
// Prepare the argument array and the working var
// TODO: Do not materialize the frame here, for now we need to do it because of a Truffle
@@ -187,7 +187,7 @@ protected Object onFunction(
}
// Place the closure in the arguments
- realArgs = ArrayUtils.concat(new Object[] {function.getClosure().getContent()}, realArgs);
+ realArgs = ArrayUtils.concat(new Object[] {function.closure.getContent()}, realArgs);
// Return the result of the function call
try {
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/FunExpr.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/FunExpr.java
index 73f2891f4..70233e4d3 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/FunExpr.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/FunExpr.java
@@ -52,6 +52,9 @@ public final class FunExpr extends Expr {
/** The names of the parameters. */
private final String[] parameterNames;
+ /** Documentation for the function */
+ private final String documentation;
+
/** The default values of the parameters. */
private final Expr[] parameterValues;
@@ -78,6 +81,7 @@ public FunExpr(
final FrameDescriptor frameDescriptor,
final ClosureDescriptor closureDescriptor,
final ParameterDeclaration[] parameters,
+ final String documentation,
final Expr body) {
super(location);
this.closureDescriptor = closureDescriptor;
@@ -86,6 +90,7 @@ public FunExpr(
this.parameterNames = new String[parameters.length];
this.parameterValues = new Expr[parameters.length];
this.body = body;
+ this.documentation = documentation;
this.initParams(parameters);
}
@@ -119,7 +124,7 @@ public LKQLFunction executeFunction(VirtualFrame frame) {
this.functionRootNode,
Closure.create(frame.materialize(), this.closureDescriptor),
Constants.FUNCTION_DEFAULT_NAME,
- Constants.FUNCTION_DEFAULT_DOC,
+ this.documentation,
this.parameterNames,
this.parameterValues);
}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/dot/DotAccess.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/dot/DotAccess.java
index b07555abf..55d78b6c8 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/dot/DotAccess.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/dot/DotAccess.java
@@ -26,10 +26,7 @@
import com.adacore.lkql_jit.LKQLContext;
import com.adacore.lkql_jit.LKQLLanguage;
import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
-import com.adacore.lkql_jit.built_ins.values.LKQLNamespace;
-import com.adacore.lkql_jit.built_ins.values.LKQLNull;
-import com.adacore.lkql_jit.built_ins.values.LKQLObject;
-import com.adacore.lkql_jit.built_ins.values.LKQLProperty;
+import com.adacore.lkql_jit.built_ins.values.*;
import com.adacore.lkql_jit.exception.LKQLRuntimeException;
import com.adacore.lkql_jit.nodes.Identifier;
import com.adacore.lkql_jit.nodes.expressions.Expr;
@@ -221,7 +218,7 @@ protected Object tryBuildIn(Object receiver) {
BuiltInFunctionValue builtIn = this.getBuiltIn(receiver);
if (builtIn != null) {
InteropLibrary builtInLibrary = InteropLibrary.getUncached(builtIn);
- if (builtIn.getParameterNames().length <= 1) {
+ if (builtIn.parameterNames.length <= 1) {
try {
return builtInLibrary.execute(builtIn, receiver);
} catch (ArityException
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/dot/SafeDotAccess.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/dot/SafeDotAccess.java
index eb55850f2..91317e7e8 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/dot/SafeDotAccess.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/dot/SafeDotAccess.java
@@ -156,7 +156,7 @@ protected Object tryBuildIn(Object receiver) {
BuiltInFunctionValue builtIn = this.getBuiltIn(receiver);
if (builtIn != null) {
InteropLibrary builtInLibrary = InteropLibrary.getUncached(builtIn);
- if (builtIn.getParameterNames().length <= 1) {
+ if (builtIn.parameterNames.length <= 1) {
try {
return builtInLibrary.execute(builtIn, receiver);
} catch (ArityException
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/literals/StringLiteral.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/literals/StringLiteral.java
index 5cf969a44..98bbdfec8 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/literals/StringLiteral.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/literals/StringLiteral.java
@@ -36,7 +36,7 @@ public final class StringLiteral extends Expr {
// ----- Attributes -----
/** The value of the string literal. */
- private final String value;
+ public final String value;
// ----- Constructors -----
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/runtime/GlobalScope.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/runtime/GlobalScope.java
index 2c65a1915..c4e804c69 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/runtime/GlobalScope.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/runtime/GlobalScope.java
@@ -23,6 +23,8 @@
package com.adacore.lkql_jit.runtime;
import com.adacore.lkql_jit.built_ins.BuiltInFunctionValue;
+import com.adacore.lkql_jit.built_ins.BuiltInsHolder;
+import com.adacore.lkql_jit.built_ins.selectors.BuiltInSelector;
import com.adacore.lkql_jit.utils.checkers.BaseChecker;
import com.oracle.truffle.api.CompilerDirectives;
import java.util.HashMap;
@@ -55,16 +57,36 @@ public final class GlobalScope {
// ----- Constructors -----
- /**
- * Create a new global scope.
- *
- * @param buildInNb The number of built-in functions.
- */
- public GlobalScope(int buildInNb) {
+ /** Create a new global scope. */
+ public GlobalScope() {
+ var builtInsHolder = BuiltInsHolder.get();
this.checkers = new HashMap<>();
- this.builtIns = new Object[buildInNb];
+ this.builtIns =
+ new Object
+ [builtInsHolder.builtInFunctions.size()
+ + builtInsHolder.builtInMethods.size()];
this.metaTables = new HashMap<>();
this.globalObjects = new HashMap<>();
+
+ // Add the built-in functions
+ for (int i = 0; i < builtInsHolder.builtInFunctions.size(); i++) {
+ BuiltInFunctionValue function = builtInsHolder.builtInFunctions.get(i);
+ builtIns[i] = function;
+ }
+
+ // Add the built-in selectors
+ for (int i = 0; i < builtInsHolder.builtInSelectors.size(); i++) {
+ BuiltInSelector selector = builtInsHolder.builtInSelectors.get(i);
+ builtIns[i + builtInsHolder.builtInFunctions.size()] = selector.getValue();
+ }
+
+ // Add the built-in methods
+ for (var entry : builtInsHolder.builtInMethods.entrySet()) {
+ var methods = new HashMap();
+ methods.putAll(builtInsHolder.commonMethods);
+ methods.putAll(entry.getValue());
+ metaTables.put(entry.getKey(), methods);
+ }
}
// ----- Instance methods -----
@@ -99,16 +121,6 @@ public Object getBuiltIn(int slot) {
return this.builtIns[slot];
}
- /**
- * Set a built-in value, this function is only used in built-in factory.
- *
- * @param slot The slot to set the built-in in.
- * @param value The value of the built-in to set.
- */
- public void setBuiltIn(int slot, Object value) {
- this.builtIns[slot] = value;
- }
-
/**
* Get a meta table for the given type.
*
@@ -120,17 +132,6 @@ public Map getMetaTable(String type) {
return this.metaTables.get(type);
}
- /**
- * Put a new meta table for a given type.
- *
- * @param type The type of the meta table.
- * @param methods The methods for the type.
- */
- @CompilerDirectives.TruffleBoundary
- public void putMetaTable(String type, Map methods) {
- this.metaTables.put(type, methods);
- }
-
public Map getGlobalObjects() {
return globalObjects;
}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/LKQLTypesHelper.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/LKQLTypesHelper.java
index 4064b903c..aa79c8034 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/LKQLTypesHelper.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/LKQLTypesHelper.java
@@ -65,7 +65,7 @@ public final class LKQLTypesHelper {
public static final String LKQL_FUNCTION = "Function";
/** The string representing the LKQL property reference type. */
- public static final String LKQL_PROPERTY_REF = "Property_Reference";
+ public static final String LKQL_PROPERTY_REF = "PropertyReference";
/** The string representing the LKQL selector type. */
public static final String LKQL_SELECTOR = "Selector";
@@ -77,10 +77,10 @@ public final class LKQLTypesHelper {
public static final String LKQL_LIST = "List";
/** The string representing the LKQL lazy list type. */
- public static final String LKQL_LAZY_LIST = "Lazy_List";
+ public static final String LKQL_LAZY_LIST = "LazyList";
/** The string representing the LKQL selector list type. */
- public static final String LKQL_SELECTOR_LIST = "Selector_List";
+ public static final String LKQL_SELECTOR_LIST = "SelectorList";
/** The string representing the LKQL object type. */
public static final String LKQL_OBJECT = "Object";
@@ -95,7 +95,7 @@ public final class LKQLTypesHelper {
public static final String TOKEN = "Token";
/** The string representing the analysis unit type. */
- public static final String ANALYSIS_UNIT = "Analysis_Unit";
+ public static final String ANALYSIS_UNIT = "AnalysisUnit";
// ----- Class methods -----
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/IntMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/TextWriter.java
similarity index 62%
rename from lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/IntMethods.java
rename to lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/TextWriter.java
index c88c02b63..630185680 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/IntMethods.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/TextWriter.java
@@ -20,48 +20,50 @@
-- --
----------------------------------------------------------------------------*/
-package com.adacore.lkql_jit.built_ins.methods;
+package com.adacore.lkql_jit.utils;
-import com.adacore.lkql_jit.utils.LKQLTypesHelper;
+import java.io.IOException;
+import java.io.Writer;
-/**
- * This class contains all built-in methods for the integer type in the LKQL language.
- *
- * @author Hugo GUERRIER
- */
-public final class IntMethods extends CommonMethods {
+public class TextWriter implements AutoCloseable {
- // ----- Attributes -----
+ private int indent;
- /** The only instance of the method collection. */
- private static IntMethods instance = null;
+ private final Writer writer;
- // ----- Constructors -----
+ public void withIndent(Runnable r) {
+ this.indent += 4;
+ r.run();
+ this.indent -= 4;
+ }
- /** Private constructor. */
- private IntMethods() {
- super();
+ public TextWriter(Writer writer) {
+ this.writer = writer;
}
- /**
- * Get the only instance of the method collection.
- *
- * @return The instance of the integer methods.
- */
- public static IntMethods getInstance() {
- if (instance == null) {
- instance = new IntMethods();
+ public void write(String str) {
+ try {
+ var lines = str.split("\\n", -1);
+ for (int i = 0; i < lines.length; i++) {
+ writeRaw(lines[i]);
+ if (i != lines.length - 1) {
+ this.writer.write("\n");
+ }
+ }
+ } catch (IOException e) {
+ throw new RuntimeException(e);
}
- return instance;
}
- // ----- Override methods -----
+ public void writeRaw(String str) throws IOException {
+ for (int i = 0; i < indent; i++) {
+ this.writer.write(" ");
+ }
+ this.writer.write(str);
+ }
- /**
- * @see BuiltInMethods#getType()
- */
@Override
- public String getType() {
- return LKQLTypesHelper.LKQL_INTEGER;
+ public void close() throws IOException {
+ this.writer.close();
}
}
diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/source_location/SourceLocation.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/source_location/SourceLocation.java
index c48fe4286..5a87b1da3 100644
--- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/source_location/SourceLocation.java
+++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/source_location/SourceLocation.java
@@ -26,6 +26,7 @@
import com.oracle.truffle.api.CompilerDirectives;
import com.oracle.truffle.api.source.Source;
import java.io.File;
+import java.util.ArrayList;
/**
* This class represents a source location.
@@ -157,6 +158,27 @@ public String[] getLines(int start, int end) {
return res;
}
+ /**
+ * @return the text for this source location.
+ */
+ @CompilerDirectives.TruffleBoundary
+ public String getText() {
+ var lines = new ArrayList();
+ for (int i = startLine; i <= endLine; i++) {
+ var line = this.source.getCharacters(i);
+ if (i == startLine && i == endLine) {
+ lines.add(line.subSequence(startColumn - 1, endColumn - 1).toString());
+ } else if (i == startLine) {
+ lines.add(line.subSequence(startColumn - 1, line.length() - 1).toString());
+ } else if (i == endLine) {
+ lines.add(line.subSequence(0, endColumn - 1).toString());
+ } else {
+ lines.add(line.toString());
+ }
+ }
+ return String.join("\n", lines);
+ }
+
// ----- Override methods -----
@Override
diff --git a/lkql_jit/lkql_cli/src/main/java/com/adacore/lkql_jit/LKQLDoc.java b/lkql_jit/lkql_cli/src/main/java/com/adacore/lkql_jit/LKQLDoc.java
new file mode 100644
index 000000000..eff4232bf
--- /dev/null
+++ b/lkql_jit/lkql_cli/src/main/java/com/adacore/lkql_jit/LKQLDoc.java
@@ -0,0 +1,99 @@
+/*----------------------------------------------------------------------------
+-- L K Q L J I T --
+-- --
+-- Copyright (C) 2022-2023, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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 --
+-- --
+----------------------------------------------------------------------------*/
+
+package com.adacore.lkql_jit;
+
+import java.io.BufferedWriter;
+import java.io.IOException;
+import java.nio.file.FileSystems;
+import java.nio.file.Files;
+import java.util.List;
+import java.util.concurrent.Callable;
+import org.graalvm.polyglot.Context;
+import org.graalvm.polyglot.Source;
+import picocli.CommandLine;
+
+@CommandLine.Command(name = "doc", description = "Generate API doc for LKQL modules, in RST format")
+public class LKQLDoc implements Callable {
+ @CommandLine.Option(
+ names = "--std",
+ description = "Generate apidoc for the prelude & builtin functions")
+ public boolean documentStd;
+
+ @CommandLine.Option(
+ names = {"-O", "--output-dir"},
+ description = "Output directory for generated RST files")
+ public String outputDir = ".";
+
+ @CommandLine.Parameters(description = "LKQL modules to document")
+ public List modules;
+
+ @Override
+ public Integer call() {
+ Context context = Context.newBuilder("lkql").allowAllAccess(true).build();
+ try {
+ Files.createDirectories(FileSystems.getDefault().getPath(outputDir));
+ } catch (IOException e) {
+ throw new RuntimeException(e);
+ }
+ if (documentStd) {
+ var path = FileSystems.getDefault().getPath(outputDir, "std.rst");
+ try (BufferedWriter writer = Files.newBufferedWriter(path)) {
+ // TODO: This eval prints the result on stdout, because we have to use
+ // "interactive" in order for the eval of the TopLevelList to return its result.
+ // We need to think about how to fix that at the language level, so that we don't
+ // have to call `eval` with `interactive=true` below.
+ var res =
+ context.eval(
+ Source.newBuilder("lkql", "document_builtins()", "")
+ .interactive(true)
+ .build());
+ writer.write(res.toString());
+ } catch (IOException e) {
+ throw new RuntimeException(e);
+ }
+ }
+
+ for (var mod : modules) {
+ var path = FileSystems.getDefault().getPath(outputDir, mod + ".rst");
+ try (BufferedWriter writer = Files.newBufferedWriter(path)) {
+ context.eval(
+ Source.newBuilder("lkql", "import " + mod, "")
+ .interactive(true)
+ .build());
+ var doc =
+ context.eval(
+ Source.newBuilder(
+ "lkql",
+ "document_namespace(" + mod + ",\"" + mod + "\")",
+ "")
+ .interactive(true)
+ .build());
+ writer.write(doc.toString());
+ } catch (IOException e) {
+ throw new RuntimeException(e);
+ }
+ }
+
+ return 0;
+ }
+}
diff --git a/lkql_jit/lkql_cli/src/main/java/com/adacore/lkql_jit/LKQLMain.java b/lkql_jit/lkql_cli/src/main/java/com/adacore/lkql_jit/LKQLMain.java
index 4674ec676..5d4fe013c 100644
--- a/lkql_jit/lkql_cli/src/main/java/com/adacore/lkql_jit/LKQLMain.java
+++ b/lkql_jit/lkql_cli/src/main/java/com/adacore/lkql_jit/LKQLMain.java
@@ -33,7 +33,8 @@
subcommands = {
LKQLLauncher.LKQLRun.class,
LKQLChecker.Args.class,
- GNATCheckWorker.Args.class
+ GNATCheckWorker.Args.class,
+ LKQLDoc.class
},
description =
"Unified driver for LKQL (Langkit query language). Allows you to run LKQL "
diff --git a/testsuite/drivers/base_driver.py b/testsuite/drivers/base_driver.py
index cb4896690..789d8425c 100644
--- a/testsuite/drivers/base_driver.py
+++ b/testsuite/drivers/base_driver.py
@@ -432,9 +432,9 @@ def _define_lkql_executables(self) -> None:
if self.env.options.mode == "jit":
python_wrapper = P.join(self.env.support_dir, "lkql_jit.py")
command_base = [sys.executable, python_wrapper]
- self.lkql_exe = [*command_base, "lkql", "run"]
- self.lkql_checker_exe = [*command_base, "lkql", "check"]
- self.gnatcheck_worker_exe = [*command_base, "lkql", "gnatcheck_worker"]
+ self.lkql_exe = [*command_base, "run"]
+ self.lkql_checker_exe = [*command_base, "check"]
+ self.gnatcheck_worker_exe = [*command_base, "gnatcheck_worker"]
# If the mode is native JIT
elif self.env.options.mode == "native_jit":
diff --git a/testsuite/drivers/gnatcheck_driver.py b/testsuite/drivers/gnatcheck_driver.py
index 751d18eb4..26c2d450b 100644
--- a/testsuite/drivers/gnatcheck_driver.py
+++ b/testsuite/drivers/gnatcheck_driver.py
@@ -178,15 +178,6 @@ def run(self) -> None:
# Get the test provided custom GNATcheck worker
custom_worker = self.test_env.get('worker', None)
- # Special case if the provided worker is "unparsable_generator" then
- # we call the lkql_jit.py script in a special mode.
- if custom_worker == "unparsable_generator":
- custom_worker = " ".join([
- sys.executable,
- P.join(self.env.support_dir, "lkql_jit.py"),
- "unparsable_generator"
- ])
-
gnatcheck_env["GNATCHECK_WORKER"] = custom_worker or " ".join(
self.gnatcheck_worker_exe
)
diff --git a/testsuite/python_support/lkql_jit.py b/testsuite/python_support/lkql_jit.py
old mode 100644
new mode 100755
index 1176f6522..5f97275d2
--- a/testsuite/python_support/lkql_jit.py
+++ b/testsuite/python_support/lkql_jit.py
@@ -1,27 +1,16 @@
+#! /usr/bin/env python
"""
Python wrapper to call the Java version of LKQL JIT.
"""
-import argparse
import os
import os.path as P
import subprocess
+import sys
-# Jar for each LKQL JIT entry point
-jars = {
- "lkql": "lkql_cli.jar"
-}
-
-# Main class for each LKQL JIT entry point
-main_classes = {
- "lkql": "LKQLMain"
-}
+if __name__ == '__main__':
-def get_java_command(entry_point: str) -> list[str]:
- """
- Get the Java command as a list of string to run the given LKQL JIT entry point.
- """
- # Get the utis paths
+ # Get the utils paths
graal_home = os.environ['GRAAL_HOME']
lkql_jit_home = os.environ.get(
'LKQL_JIT_HOME',
@@ -29,60 +18,25 @@ def get_java_command(entry_point: str) -> list[str]:
)
# Get the Java executable
- java = (
- P.join(graal_home, 'bin', 'java.exe')
- if os.name == 'nt' else
- P.join(graal_home, 'bin', 'java')
- )
+ java = P.join(graal_home, 'bin', 'java.exe' if os.name == 'nt' else 'java')
# Create the class path
class_path = os.pathsep.join([
P.join(graal_home, 'lib', 'truffle', 'truffle-api.jar'),
P.join(lkql_jit_home, 'lkql_jit.jar'),
- P.join(lkql_jit_home, jars[entry_point])
+ P.join(lkql_jit_home, 'lkql_cli.jar')
])
# Create the java.library.path property
- java_library_path = (
- os.environ.get('PATH', "")
- if os.name == 'nt' else
- os.environ.get('LD_LIBRARY_PATH', "")
+ java_library_path = os.environ.get(
+ 'PATH' if os.name == 'nt' else "LD_LIBRARY_PATH", ""
)
- # Return the full command
- return [
+ # Run the full command
+ subprocess.run([
java,
'-cp', class_path,
f'-Djava.library.path={java_library_path}',
f'-Dtruffle.class.path.append={P.join(lkql_jit_home, "lkql_jit.jar")}',
- f'com.adacore.lkql_jit.{main_classes[entry_point]}'
- ]
-
-def print_gnatcheck_unparsable():
- print("This line is not parsable")
- print("Message: should appear")
- print("no_a_file.adb:01:01: Message: Should not appear")
- print("This line is not parsable either")
-
-if __name__ == '__main__':
- # Create the script argument parser
- parser = argparse.ArgumentParser(prog="lkql_jit.py",
- description=__doc__)
- subparsers = parser.add_subparsers(help="LKQL JIT entry point", required=True)
- for subcommand, help in [
- ("lkql", "Main entry point for LKQL"),
- (
- "unparsable_generator",
- "Entry point to generate unparsable GNATcheck messages"
- )
- ]:
- subp = subparsers.add_parser(subcommand, help=help)
- subp.set_defaults(subc=subcommand)
-
- args, to_forward = parser.parse_known_args()
- if args.subc == "unparsable_generator":
- print_gnatcheck_unparsable()
- else:
- command = get_java_command(args.subc)
- command.extend(to_forward)
- subprocess.run(command)
+ f'com.adacore.lkql_jit.LKQLMain'
+ ] + sys.argv[1:])
diff --git a/testsuite/tests/gnatcheck_errors/unparsable_worker_messages/bogus_lkql.py b/testsuite/tests/gnatcheck_errors/unparsable_worker_messages/bogus_lkql.py
new file mode 100644
index 000000000..c4067a4dd
--- /dev/null
+++ b/testsuite/tests/gnatcheck_errors/unparsable_worker_messages/bogus_lkql.py
@@ -0,0 +1,5 @@
+if __name__ == '__main__':
+ print("This line is not parsable")
+ print("Message: should appear")
+ print("no_a_file.adb:01:01: Message: Should not appear")
+ print("This line is not parsable either")
diff --git a/testsuite/tests/gnatcheck_errors/unparsable_worker_messages/test.yaml b/testsuite/tests/gnatcheck_errors/unparsable_worker_messages/test.yaml
index b3f3b9779..3277368f9 100644
--- a/testsuite/tests/gnatcheck_errors/unparsable_worker_messages/test.yaml
+++ b/testsuite/tests/gnatcheck_errors/unparsable_worker_messages/test.yaml
@@ -1,6 +1,6 @@
driver: gnatcheck
format: brief
-worker: "unparsable_generator"
+worker: "python bogus_lkql.py"
input_sources:
- main.adb
rules:
diff --git a/testsuite/tests/interpreter/block_strings/script.lkql b/testsuite/tests/interpreter/block_strings/script.lkql
new file mode 100644
index 000000000..626f5ba83
--- /dev/null
+++ b/testsuite/tests/interpreter/block_strings/script.lkql
@@ -0,0 +1,4 @@
+print(
+ |" Hello
+ |" world
+)
diff --git a/testsuite/tests/interpreter/block_strings/test.out b/testsuite/tests/interpreter/block_strings/test.out
new file mode 100644
index 000000000..65a56c31f
--- /dev/null
+++ b/testsuite/tests/interpreter/block_strings/test.out
@@ -0,0 +1,2 @@
+Hello
+world
diff --git a/testsuite/tests/interpreter/block_strings/test.yaml b/testsuite/tests/interpreter/block_strings/test.yaml
new file mode 100644
index 000000000..c5e30112e
--- /dev/null
+++ b/testsuite/tests/interpreter/block_strings/test.yaml
@@ -0,0 +1,2 @@
+driver: 'interpreter'
+project: 'default_project/default.gpr'
diff --git a/testsuite/tests/interpreter/doc/script.lkql b/testsuite/tests/interpreter/doc/script.lkql
index 4bab35237..95e6ad460 100644
--- a/testsuite/tests/interpreter/doc/script.lkql
+++ b/testsuite/tests/interpreter/doc/script.lkql
@@ -1,3 +1,16 @@
+import test_module
+
+fun user_fn() =
+ |" This is the docstring
+ 12
+
+selector user_selector
+ |" This is the selector's docstring
+ | null => ()
+
print(print.doc)
print(doc.doc)
-print(children.doc)
\ No newline at end of file
+print(children.doc)
+print(user_fn.doc)
+print(user_selector.doc)
+print(test_module.doc)
diff --git a/testsuite/tests/interpreter/doc/test.out b/testsuite/tests/interpreter/doc/test.out
index 541c44f9d..06e339f05 100644
--- a/testsuite/tests/interpreter/doc/test.out
+++ b/testsuite/tests/interpreter/doc/test.out
@@ -2,3 +2,6 @@ Built-in print function. Prints whatever is passed as an argument
Given any object, return the documentation associated with it
Yields all the descendants of the given node in the tree
+This is the docstring
+This is the selector's docstring
+Pouet pouet pouet pouet
diff --git a/testsuite/tests/interpreter/doc/test_module.lkql b/testsuite/tests/interpreter/doc/test_module.lkql
new file mode 100644
index 000000000..5dbb8d73c
--- /dev/null
+++ b/testsuite/tests/interpreter/doc/test_module.lkql
@@ -0,0 +1,3 @@
+|" Pouet pouet pouet pouet
+
+fun user_fn() = 12
diff --git a/testsuite/tests/interpreter/profile/script.lkql b/testsuite/tests/interpreter/profile/script.lkql
new file mode 100644
index 000000000..e5ea4c8a0
--- /dev/null
+++ b/testsuite/tests/interpreter/profile/script.lkql
@@ -0,0 +1,7 @@
+selector bar
+ | null => ()
+
+fun foo(a=12, b=(13, 14)) = a + b[0] + b[1]
+
+print(profile(foo))
+print(profile(bar))
diff --git a/testsuite/tests/interpreter/profile/test.out b/testsuite/tests/interpreter/profile/test.out
new file mode 100644
index 000000000..f0b5b899d
--- /dev/null
+++ b/testsuite/tests/interpreter/profile/test.out
@@ -0,0 +1,2 @@
+foo(a=12, b=(13, 14))
+bar()
diff --git a/testsuite/tests/interpreter/profile/test.yaml b/testsuite/tests/interpreter/profile/test.yaml
new file mode 100644
index 000000000..c5e30112e
--- /dev/null
+++ b/testsuite/tests/interpreter/profile/test.yaml
@@ -0,0 +1,2 @@
+driver: 'interpreter'
+project: 'default_project/default.gpr'
diff --git a/testsuite/tests/interpreter/user_fn_doc/script.lkql b/testsuite/tests/interpreter/user_fn_doc/script.lkql
new file mode 100644
index 000000000..59c94bbee
--- /dev/null
+++ b/testsuite/tests/interpreter/user_fn_doc/script.lkql
@@ -0,0 +1,5 @@
+fun foo(a=12, b=(13, 14)) =
+ |" Compute the foo frobulation
+ a + b[0] + b[1]
+
+print(doc(foo))
diff --git a/testsuite/tests/interpreter/user_fn_doc/test.out b/testsuite/tests/interpreter/user_fn_doc/test.out
new file mode 100644
index 000000000..5b9e09d0e
--- /dev/null
+++ b/testsuite/tests/interpreter/user_fn_doc/test.out
@@ -0,0 +1 @@
+Compute the foo frobulation
diff --git a/testsuite/tests/interpreter/user_fn_doc/test.yaml b/testsuite/tests/interpreter/user_fn_doc/test.yaml
new file mode 100644
index 000000000..c5e30112e
--- /dev/null
+++ b/testsuite/tests/interpreter/user_fn_doc/test.yaml
@@ -0,0 +1,2 @@
+driver: 'interpreter'
+project: 'default_project/default.gpr'
diff --git a/testsuite/tests/interpreter_errors/invalid_block_string/script.lkql b/testsuite/tests/interpreter_errors/invalid_block_string/script.lkql
new file mode 100644
index 000000000..609388509
--- /dev/null
+++ b/testsuite/tests/interpreter_errors/invalid_block_string/script.lkql
@@ -0,0 +1,3 @@
+print(
+|"pouet
+)
diff --git a/testsuite/tests/interpreter_errors/invalid_block_string/test.out b/testsuite/tests/interpreter_errors/invalid_block_string/test.out
new file mode 100644
index 000000000..623343aab
--- /dev/null
+++ b/testsuite/tests/interpreter_errors/invalid_block_string/test.out
@@ -0,0 +1 @@
+Invalid blockstring: first character should be whitespace
diff --git a/testsuite/tests/interpreter_errors/invalid_block_string/test.yaml b/testsuite/tests/interpreter_errors/invalid_block_string/test.yaml
new file mode 100644
index 000000000..5a6367d3b
--- /dev/null
+++ b/testsuite/tests/interpreter_errors/invalid_block_string/test.yaml
@@ -0,0 +1,2 @@
+driver: interpreter
+project: 'default_project/default.gpr'
diff --git a/user_manual/Makefile b/user_manual/Makefile
index e1e7ec8f1..da0c9b310 100644
--- a/user_manual/Makefile
+++ b/user_manual/Makefile
@@ -19,5 +19,5 @@ ROOT_DIR:=$(shell dirname $(realpath $(firstword $(MAKEFILE_LIST))))
# Catch-all target: route all unknown targets to Sphinx using the new
# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS).
%: Makefile
- LKQL_PATH=$(ROOT_DIR)/../lkql_checker/share/lkql python generate_apidoc.py --std -O generated stdlib
+ LKQL_PATH=$(ROOT_DIR)/../lkql_checker/share/lkql lkql doc --std -O generated stdlib
@$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
diff --git a/user_manual/generate_apidoc.py b/user_manual/generate_apidoc.py
deleted file mode 100644
index ac396dce3..000000000
--- a/user_manual/generate_apidoc.py
+++ /dev/null
@@ -1,192 +0,0 @@
-"""
-APIdoc generation script for LKQL. It can be used to generate a sphinx file
-containing API documentation for given LKQL modules.
-
-Limitations:
-
-- For the moment it is only able to document functions and selectors.
-
-- We don't have an LKQL sphinx domain, so this piggybacks on the python domain.
- This implies some limitations (like, for example, selectors are documented as
- functions for now).
-"""
-
-import argparse
-import liblkqllang as L
-from os import path as P, makedirs
-import re
-
-from contextlib import contextmanager
-
-SCRIPT_PATH = P.dirname(P.realpath(__file__))
-
-PROF_RE = re.compile(r"(?P@builtin )?"
- r"(?Pfun|selector)\s*(?P.*)")
-
-
-class App(object):
-
- def __init__(self, *args, **kwargs):
- super().__init__(*args, **kwargs)
- self.eval_counter = 0
- self.output = []
- self._indent = 0
- self.ctx = L.AnalysisContext()
- self.parser = argparse.ArgumentParser()
- self.parser.add_argument(
- 'modules', nargs='*', help="LKQL module names to document"
- )
- self.parser.add_argument(
- '--std', action="store_true",
- help='Generate apidoc for the prelude & builtin functions'
- )
- self.parser.add_argument(
- '-O', '--output-dir', type=str,
- default=".",
- help='Output directory for the generated rst files'
- )
-
- def write(self, *chunks):
- """
- Write chunks to the current file, taking current indentation into
- account.
- """
- for chunk in chunks:
- if chunk == '':
- self.output.append('')
- continue
-
- for line in chunk.splitlines():
- self.output.append((' ' * self ._indent) + line)
-
- def get_output(self):
- """
- Return current output formatted properly.
- """
- return "\n".join(self.output)
-
- @contextmanager
- def output_file(self, file_name):
- """
- Context manager to set the output file. Writes the content of the
- current buffer to the file and flushes the buffer on exit.
- """
- makedirs(self.args.output_dir, exist_ok=True)
- try:
- self.output_file_name = file_name
- yield
- finally:
- with open(
- P.join(self.args.output_dir, self.output_file_name), "w"
- ) as f:
- f.write(self.get_output())
- self.output = []
-
- @contextmanager
- def indent(self):
- """
- Context manager to indent sphinx code emitted inside the with block.
- """
- try:
- self._indent += 4
- yield
- finally:
- self._indent -= 4
-
- def eval(self, cmd):
- """
- Eval given LKQL command and returns the result as a string.
- """
- cmd = self.ctx.get_from_buffer(f"', '12')
- dummy_unit.root.p_interp_init_from_project(
- P.join(SCRIPT_PATH, "apidoc_default.gpr")
- )
-
- if self.args.std:
- local_symbols = sorted(eval(self.eval("get_symbols()")))
- with self.output_file('std.rst'):
- self.write('Standard Library')
- self.write('----------------')
- self.write('')
-
- self.write('Builtin Functions')
- self.write('^^^^^^^^^^^^^^^^^')
- self.write('')
- self.generate_module_doc(local_symbols)
-
- self.write('Builtin Methods')
- self.write('^^^^^^^^^^^^^^^')
- self.write('')
- builtin_methods = eval(self.eval("get_builtin_methods_info()"))
-
- for method in builtin_methods.values():
- receiver_kind = method["params"][0][1]
- if receiver_kind == "NO_KIND":
- receiver_kind = "Object"
- else:
- receiver_kind = receiver_kind[5:].lower().capitalize()
- self.write(
- f'.. method:: {receiver_kind}.{method["name"]} '
- '({params})'
- )
- with self.indent():
- self.write('')
- self.write(method["doc"])
- self.write('')
-
- for module_name in self.args.modules:
- self.eval(f"import {module_name}")
- module_symbols = sorted(eval(self.eval(
- f"get_symbols({module_name})"))
- )
- with self.output_file(f'{module_name}.rst'):
- self.write(f'API Doc For Module {module_name}')
- self.write('--------------------------------')
- self.write('')
- self.generate_module_doc(module_symbols, module_name)
-
-
-if __name__ == '__main__':
- App().main()
diff --git a/user_manual/generated/std.rst b/user_manual/generated/std.rst
index 8e922f71e..09a18b8c8 100644
--- a/user_manual/generated/std.rst
+++ b/user_manual/generated/std.rst
@@ -1,236 +1,329 @@
-Standard Library
+Standard library
----------------
-Builtin Functions
+Builtin functions
^^^^^^^^^^^^^^^^^
-.. function:: base_name(str)
+.. function:: print(val, new_line)
- Given a string that represents a file name, returns the basename
+ Built-in print function. Prints whatever is passed as an argument
-.. function:: children
+.. function:: img(val)
- Yields all the descendants of the given node in the tree
+ Return a string representation of an object
+
+.. function:: base_name(str)
+
+ Given a string that represents a file name, returns the basename
.. function:: concat(lists)
Given a list of lists or strings, return a concatenated list or string
+.. function:: reduce(indexable, fn, init)
+
+ Given a collection, a reduction function, and an initial value reduce the result
+
+.. function:: map(indexable, fn)
+
+ Given a collection, a mapping function
+
+.. function:: unique(indexable)
+
+ Given collection, remove all identical elements in order to have only one instance of each
+
.. function:: doc(obj)
Given any object, return the documentation associated with it
-.. function:: get_builtin_methods_info()
+.. function:: profile(obj)
- Return information about builtin methods
+ Given any object, if it is a callable, return its profile as text
-.. function:: get_symbols(package=())
+.. function:: document_builtins()
- Given a module, return the symbols stored in it. If given no module, return the local symbols
+ Return a string in the RsT format containing documentation for all built-ins
-.. function:: help(obj)
+.. function:: document_namespace(namespace, name)
- Given any object, return formatted help for it
+ Return a string in the RsT format containing documentation for all built-ins
-.. function:: img(val)
+.. function:: help(obj)
- Return a string representation of an object
+ Given any object, return formatted help for it
-.. function:: next_siblings
+.. function:: units()
- Yields the siblings following the given node in the tree
+ Return an iterator on all units
-.. function:: parent
+.. function:: specified_units()
- Yields the parents (ancestors) of the given node in the tree
+ Return an iterator on units specified by the user
-.. function:: pattern(string_pattern, case_sensitive=true)
+.. function:: pattern(regex, case_sensitive)
Given a regex pattern string, create a pattern object
-.. function:: prev_siblings
+.. function:: node_checker(root)
- Yields the siblings preceding the given node in the tree
+ Given a root, execute all node checker while traverse the tree
-.. function:: print(val, new_line=true)
+.. function:: unit_checker(unit)
- Built-in print function. Prints whatever is passed as an argument
+ Given a unit, apply all the unit checker on it
-.. function:: profile(obj)
+Builtin selectors
+^^^^^^^^^^^^^^^^^
- Given any object, if it is a callable, return its profile as text
+.. function:: children()
-.. function:: reduce(indexable, fn, init)
+ Yields all the descendants of the given node in the tree
+
- Given a collection, a reduction function, and an initial value reduce the result
+.. function:: parent()
-.. function:: super_types
+ Yields the parents (ancestors) of the given node in the tree
+
- Given a TypeDecl node, yields all the super types of the type
+.. function:: next_siblings()
-.. function:: unique(indexable)
+ Yields the siblings following the given node in the tree
+
+.. function:: prev_siblings()
+ Yields the siblings preceding the given node in the tree
+
-.. function:: units()
+.. function:: super_types()
- Return an iterator on all units
+ Given a TypeDecl node, yields all the super types of the type
+
-Builtin Methods
+Builtin methods
^^^^^^^^^^^^^^^
-.. method:: Str.base_name ({params})
+Methods for `Any`
+"""""""""""""""""
+.. method:: Any.doc(obj)
- Given a string that represents a file name, returns the basename
+ Given any object, return the documentation associated with it
-.. method:: Node.children_count ({params})
+.. method:: Any.img(val)
- Given a node, return the count of its children
+ Return a string representation of an object
-.. method:: List.concat ({params})
+.. method:: Any.print(val, new_line)
- Given a list of lists or strings, return a concatenated list or string
+ Built-in print function. Prints whatever is passed as an argument
-.. method:: Str.contains ({params})
+Methods for `AnalysisUnit`
+""""""""""""""""""""""""""
+.. method:: AnalysisUnit.name(unit)
- Search for `to_find` in the given string. Return whether a match is found. ``to_find`` can be either a pattern or a string
+ Return the name of this unit
-.. method:: Object.doc ({params})
+.. method:: AnalysisUnit.root(unit)
- Given any object, return the documentation associated with it
+ Return the root for this unit
-.. method:: Node.dump ({params})
+.. method:: AnalysisUnit.text(unit)
- Given an ast node, return a structured dump of the subtree
+ Return the text of the analysis unit
-.. method:: Token.end_column ({params})
+.. method:: AnalysisUnit.tokens(unit)
- Return the column end
+ Return the tokens of the unit
-.. method:: Token.end_line ({params})
+Methods for `LazyList`
+""""""""""""""""""""""
+.. method:: LazyList.length(iterable)
- Return the line end
+ Get the length of the iterable element
-.. method:: Str.ends_with ({params})
+.. method:: LazyList.reduce(indexable, fn, init)
- Given a string, returns whether it ends with the given suffix
+ Given a collection, a reduction function, and an initial value reduce the result
-.. method:: Str.find ({params})
+.. method:: LazyList.to_list(iterable)
- Search for `to_find` in the given string. Return position of the match, or -1 if no match. ``to_find`` can be either a pattern or a string
+ Transform an iterator into a list
-.. method:: Namespace.get_symbols ({params})
+Methods for `List`
+""""""""""""""""""
+.. method:: List.length(iterable)
- Given a module, return the symbols stored in it. If given no module, return the local symbols
+ Get the length of the iterable element
-.. method:: Object.help ({params})
+.. method:: List.reduce(indexable, fn, init)
- Given any object, return formatted help for it
+ Given a collection, a reduction function, and an initial value reduce the result
-.. method:: Object.img ({params})
+.. method:: List.sublist(list, low_bound, high_bound)
- Return a string representation of an object
+ Return a sublist of `list` from `low_bound` to `high_bound`
-.. method:: Token.is_equivalent ({params})
+.. method:: List.to_list(iterable)
- Return whether two tokens are structurally equivalent
+ Transform an iterator into a list
-.. method:: Str.is_lower_case ({params})
+.. method:: List.unique(indexable)
- Return whether the given string contains lower case characters only
+ Given collection, remove all identical elements in order to have only one instance of each
-.. method:: Str.is_mixed_case ({params})
+Methods for `Node`
+""""""""""""""""""
+.. method:: Node.children(node)
- Return whether the given string is written in mixed case, that is, with only lower case characters except the first one and every character following an underscore
+ Given a node, get the list of all its children
-.. method:: Token.is_trivia ({params})
+.. method:: Node.children_count(node)
- Return whether this token is a trivia
+ Given a node, return the count of its children
-.. method:: Str.is_upper_case ({params})
+.. method:: Node.dump(node)
- Return whether the given string contains upper case characters only
+ Given an ast node, return a structured dump of the subtree
+
+.. method:: Node.image(node)
-.. method:: Node.kind ({params})
+ Given an ast node, return its image
+
+.. method:: Node.kind(node)
Return the kind of this node, as a string
-.. method:: Analysis_unit.name ({params})
+.. method:: Node.parent(node)
- Return the name of this unit
+ Given a node, get the parent of it
-.. method:: Token.next ({params})
+.. method:: Node.same_tokens(node, other)
- Return the next token
+ Return whether two nodes have the same tokens, ignoring trivias
-.. method:: Str.pattern ({params})
+.. method:: Node.text(node)
- Given a regex pattern string, create a pattern object
+ Given an ast node, return its text
-.. method:: Token.previous ({params})
+.. method:: Node.tokens(node)
- Return the previous token
+ Given a node, return an iterator on its tokens
-.. method:: Object.print ({params})
+.. method:: Node.unit(node)
- Built-in print function. Prints whatever is passed as an argument
+ Given an ast node, return its analysis unit
-.. method:: Object.profile ({params})
+Methods for `SelectorList`
+""""""""""""""""""""""""""
+.. method:: SelectorList.length(iterable)
- Given any object, if it is a callable, return its profile as text
+ Get the length of the iterable element
-.. method:: Object.reduce ({params})
+.. method:: SelectorList.reduce(indexable, fn, init)
Given a collection, a reduction function, and an initial value reduce the result
-.. method:: Analysis_unit.root ({params})
+.. method:: SelectorList.to_list(iterable)
- Return the root for this unit
+ Transform an iterator into a list
-.. method:: Node.same_tokens ({params})
+Methods for `Str`
+"""""""""""""""""
+.. method:: Str.base_name(str)
- Return whether two nodes have the same tokens, ignoring trivias
+ Given a string that represents a file name, returns the basename
-.. method:: Str.split ({params})
+.. method:: Str.contains(str, to_find)
- Given a string, return an iterator on the words contained by str separated by separator
+ Search for to_find in the given string. Return whether a match is found. to_find can be either a pattern or a string
-.. method:: Token.start_column ({params})
+.. method:: Str.ends_with(str, suffix)
- Return the column start
+ Given a string, returns whether it ends with the given suffix
-.. method:: Token.start_line ({params})
+.. method:: Str.find(str, to_find)
- Return the line start
+ Search for to_find in the given string. Return position of the match, or -1 if no match. to_find can be either a pattern or a string
+
+.. method:: Str.is_lower_case(str)
+
+ Return whether the given string contains lower case characters only
+
+.. method:: Str.is_mixed_case(str)
+
+ Return whether the given string is written in mixed case, that is, with only lower case characters except the first one and every character following an underscore
+
+.. method:: Str.is_upper_case(str)
+
+ Return whether the given string contains upper case characters only
+
+.. method:: Str.length(str)
+
+ Given a string, return the length of it in character
-.. method:: Str.starts_with ({params})
+.. method:: Str.split(str, separator)
+
+ Given a string, return an iterator on the words contained by str separated by separator
+
+.. method:: Str.starts_with(str, prefix)
Given a string, returns whether it starts with the given prefix
-.. method:: Str.substring ({params})
+.. method:: Str.substring(str, from, to)
Given a string and two indices (from and to), return the substring contained between indices from and to (both included)
-.. method:: Node.text ({params})
+.. method:: Str.to_lower_case(str)
- Given an ast node, return its text
+ Return the given string written with lower case characters only
-.. method:: Object.to_list ({params})
+.. method:: Str.to_upper_case(str)
- Transform an iterator into a list
+ Return the given string written with upper case characters only
-.. method:: Str.to_lower_case ({params})
+Methods for `Token`
+"""""""""""""""""""
+.. method:: Token.end_column(token)
- Return the given string written with lower case characters only
+ Return the column end
-.. method:: Node.tokens ({params})
+.. method:: Token.end_line(token)
- Given a node, return an iterator on its tokens
+ Return the line end
-.. method:: Object.unique ({params})
+.. method:: Token.is_equivalent(this, other)
+ Return whether two tokens are structurally equivalent
+
+.. method:: Token.is_trivia(token)
+
+ Return whether this token is a trivia
+.. method:: Token.kind(token)
-.. method:: Token.unit ({params})
+ Return the kind of the token
+
+.. method:: Token.next(token, exclude_trivia)
+
+ Return the next token
+
+.. method:: Token.previous(token, exclude_trivia)
+
+ Return the previous token
+
+.. method:: Token.start_column(token)
+
+ Return the column start
+
+.. method:: Token.start_line(token)
+
+ Return the line start
+
+.. method:: Token.text(token)
+
+ Return the text of the token
+
+.. method:: Token.unit(token)
Return the unit for this token
+
diff --git a/user_manual/generated/stdlib.rst b/user_manual/generated/stdlib.rst
index 44b36422e..785481f9e 100644
--- a/user_manual/generated/stdlib.rst
+++ b/user_manual/generated/stdlib.rst
@@ -1,12 +1,8 @@
-API Doc For Module stdlib
---------------------------------
-
-LKQL stdlib module
-
-This module contains functions that are shared accross lkql_checker rules.
-These functions may be moved in the future in Libadalang or LKQL's builtin
-library.
+stdlib's API doc
+----------------
+Functions
+^^^^^^^^^
.. function:: all(iterable)
Return whether all elements in the given iterable are truthy
@@ -15,29 +11,20 @@ library.
Return whether at least one element in the given iterable is truthy
-.. function:: children_no_nested
-
- Return all children nodes starting from a base subprogram body, but not
- entering in nested bodies.
-
.. function:: closest_enclosing_generic(n)
If ``n`` is part of a generic package or subprogram, whether it is
instantiated or not, then return it.
-.. function:: component_types
-
- Return all the BaseTypeDecl corresponding to all fields
- of a given type, including their full views, base types and subtypes.
-
.. function:: default_bit_order()
- Return the value of System.Default_Bit_Order if any ``with System``
+ Return the value of ``System.Default_Bit_Order`` if any ``with System``
clause is found, null otherwise.
.. function:: enclosing_block(n)
- Return the first DeclBlock enclosing n if any, null otherwise
+ Return the first ``DeclBlock`` enclosing ``n`` if any, ``null``
+ otherwise.
.. function:: enclosing_body(n)
@@ -57,18 +44,14 @@ library.
Return the index of the first non blank character of s, starting at ind
-.. function:: full_parent_types
-
- Return all base (sub)types full views
-
.. function:: full_root_type(t)
- Return the full view of the root type of t, traversing subtypes,
+ Return the full view of the root type of ``t``, traversing subtypes,
derivations and privacy.
.. function:: get_parameter(params, actual)
- Given a List[ParamActual], return the parameter corresponding to
+ Given a ``List[ParamActual]``, return the parameter corresponding to
actual, null if actual is not found.
.. function:: get_subp_body(node)
@@ -86,8 +69,9 @@ library.
.. function:: has_non_default_sso(decl)
- Return true if ``decl`` has a Scalar_Storage_Order aspect whose value
- cannot be determined to be equal to System.Default_Storage_Order.
+ Return true if ``decl`` has a ``Scalar_Storage_Order`` aspect whose
+ value cannot be determined to be equal to
+ ``System.Default_Storage_Order``.
.. function:: in_generic_instance(n)
@@ -109,7 +93,8 @@ library.
.. function:: is_by_copy(param)
- Return true if ``param`` (a ParamActual) has a non aliased by-copy type
+ Return true if ``param`` (a ``ParamActual``) has a non aliased by-copy
+ type
.. function:: is_classwide_type(t)
@@ -148,12 +133,12 @@ library.
.. function:: is_predefined_op(op, follow_renamings=false)
- Return true if op is a predefined operator
+ Return true if ``op`` is a predefined operator
.. function:: is_predefined_type(n)
- Return true if n is the name of a type declared in a predefined package
- spec.
+ Return true if ``n`` is the name of a type declared in a predefined
+ package spec.
.. function:: is_program_unit(n)
@@ -161,7 +146,7 @@ library.
.. function:: is_standard_boolean(n)
- Return true if the root type of n is Standard.Boolean
+ Return true if the root type of ``n`` is ``Standard.Boolean``.
.. function:: is_standard_numeric(n)
@@ -195,18 +180,10 @@ library.
Return the number of values covered by a given BaseTypeDecl, -1 if
this value cannot be determined.
-.. function:: param_pos(n, pos: int = 0)
+.. function:: param_pos(n, pos=0)
Return the position of node ``n`` in its current list of siblings
-.. function:: parent_decl_chain
-
- Return all parent basic decl nodes starting from a given node, using
- semantic parent.
- When on a subprogram or package body, go to the declaration
- This allows us to, if in a generic template, always find back the
- generic formal.
-
.. function:: previous_non_blank_token_line(token)
Return the end line of the previous non blank token, or the previous
@@ -215,34 +192,31 @@ library.
.. function:: propagate_exceptions(body)
Return true if the given body may propagate an exception, namely if:
- - it has no exception handler with a "when others" choice;
+ - it has no exception handler with a ``when others`` choice;
- or it has an exception handler containing a raise statement, or a call
- to Ada.Exception.Raise_Exception or Ada.Exception.Reraise_Occurrence.
+ to ``Ada.Exception.Raise_Exception`` or
+ ``Ada.Exception.Reraise_Occurrence``.
.. function:: range_values(left, right)
Return the number of values covered between left and right expressions,
-1 if it cannot be determined.
-.. function:: semantic_parent
-
- Return all semantic parent nodes starting from a given node.
-
.. function:: sloc_image(node)
Return a string with basename:line corresponding to node's sloc
.. function:: strip_conversions(node)
- Strip ParenExpr, QualExpr and type conversions
+ Strip ``ParenExpr``, ``QualExpr`` and type conversions
.. function:: ultimate_alias(name, all_nodes=true, strip_component=false)
Return the ultimately designated ``ObjectDecl``, going through renamings
This will not go through generic instantiations. If all_nodes is true,
- consider all kinds of nodes, otherwise consider only BaseId and
- DottedName. If strip_component is true, go to the prefix when
- encountering a component, otherwise stop at the ComponentDecl.
+ consider all kinds of nodes, otherwise consider only ``BaseId`` and
+ ``DottedName``. If ``strip_component`` is true, go to the prefix when
+ encountering a component, otherwise stop at the ``ComponentDecl``.
.. function:: ultimate_designated_generic_subp(subp_inst)
@@ -255,8 +229,8 @@ library.
.. function:: ultimate_prefix(n)
- Return n.f_prefix as long as n is a DottedName and designates a
- ComponentDecl, n otherwise.
+ Return ``n.f_prefix`` as long as ``n`` is a ``DottedName`` and
+ designates a ``ComponentDecl``, ``n`` otherwise.
.. function:: ultimate_subprogram_alias(name)
@@ -266,3 +240,32 @@ library.
Return ``true`` if ``node`` is part of an assertion-related pragma or
aspect.
+
+Selectors
+^^^^^^^^^
+.. function:: children_no_nested()
+
+ Return all children nodes starting from a base subprogram body, but not
+ entering in nested bodies.
+
+.. function:: component_types()
+
+ Return all the ``BaseTypeDecl``s corresponding to all fields of a given
+ type, including their full views, base types and subtypes.
+
+.. function:: full_parent_types()
+
+ Return all base (sub)types full views
+
+.. function:: parent_decl_chain()
+
+ Return all parent basic decl nodes starting from a given node, using
+ semantic parent.
+ When on a subprogram or package body, go to the declaration
+ This allows us to, if in a generic template, always find back the
+ generic formal.
+
+.. function:: semantic_parent()
+
+ Return all semantic parent nodes starting from a given node.
+
diff --git a/user_manual/source/language_reference.rst b/user_manual/source/language_reference.rst
index a1c632c0d..0226a5ca0 100644
--- a/user_manual/source/language_reference.rst
+++ b/user_manual/source/language_reference.rst
@@ -597,8 +597,8 @@ LKQL has literals for booleans, integers, strings, and null values:
val c = "hello"
val d = null
-LKQL has multi-line string literals, but they're a bit different than in Python
-or other languages:
+LKQL has multi-line string literals, called block-strings but they're a bit
+different than in Python or other languages:
.. code-block:: lkql
@@ -606,6 +606,10 @@ or other languages:
|" This is a multi line string
|" Bue
+.. note:: The first character after the ``"`` should be a whitespace. This is
+ not enforced at parse-time but at run-time, so ``|"hello`` is still a
+ syntactically valid block-string, but will raise an error when evaluated.
+
LKQL has a few built-in operators available:
- Basic arithmetic operators on integers