From 1a117e331fc66d1dbe09e0f49a4cd99c7dcc3e43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Tue, 5 Dec 2023 12:31:40 +0100 Subject: [PATCH 01/14] Mini clean-up of lkql_jit.py Get rid of the subcommand, just make it a pure wrapper for the Java lkql driver. --- testsuite/drivers/base_driver.py | 6 +- testsuite/drivers/gnatcheck_driver.py | 9 --- testsuite/python_support/lkql_jit.py | 70 ++++--------------- .../unparsable_worker_messages/bogus_lkql.py | 5 ++ .../unparsable_worker_messages/test.yaml | 2 +- 5 files changed, 21 insertions(+), 71 deletions(-) mode change 100644 => 100755 testsuite/python_support/lkql_jit.py create mode 100644 testsuite/tests/gnatcheck_errors/unparsable_worker_messages/bogus_lkql.py 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: From c82d57208b3083357218bd041e6abcd8b1f00e1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Wed, 6 Dec 2023 15:35:31 +0100 Subject: [PATCH 02/14] Implement lkqlProfile on functions --- .../built_ins/values/LKQLFunction.java | 16 ++++++++++++++ .../utils/source_location/SourceLocation.java | 22 +++++++++++++++++++ .../tests/interpreter/profile/script.lkql | 2 ++ testsuite/tests/interpreter/profile/test.out | 1 + testsuite/tests/interpreter/profile/test.yaml | 2 ++ 5 files changed, 43 insertions(+) create mode 100644 testsuite/tests/interpreter/profile/script.lkql create mode 100644 testsuite/tests/interpreter/profile/test.out create mode 100644 testsuite/tests/interpreter/profile/test.yaml 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..1346f786e 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) @@ -215,4 +216,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/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/testsuite/tests/interpreter/profile/script.lkql b/testsuite/tests/interpreter/profile/script.lkql new file mode 100644 index 000000000..d714c6d20 --- /dev/null +++ b/testsuite/tests/interpreter/profile/script.lkql @@ -0,0 +1,2 @@ +fun foo(a=12, b=(13, 14)) = a + b[0] + b[1] +print(profile(foo)) diff --git a/testsuite/tests/interpreter/profile/test.out b/testsuite/tests/interpreter/profile/test.out new file mode 100644 index 000000000..48fb76d3e --- /dev/null +++ b/testsuite/tests/interpreter/profile/test.out @@ -0,0 +1 @@ +foo(a=12, b=(13, 14)) 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' From d06fc3531a7e024dadf78efd225f4f89af0aef79 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Wed, 6 Dec 2023 16:43:38 +0100 Subject: [PATCH 03/14] Fix doc(func) --- .../langkit_translator/passes/TranslationPass.java | 3 +++ .../com/adacore/lkql_jit/nodes/expressions/FunExpr.java | 7 ++++++- testsuite/tests/interpreter/doc/script.lkql | 7 ++++++- testsuite/tests/interpreter/doc/test.out | 1 + testsuite/tests/interpreter/user_fn_doc/script.lkql | 5 +++++ testsuite/tests/interpreter/user_fn_doc/test.out | 1 + testsuite/tests/interpreter/user_fn_doc/test.yaml | 2 ++ 7 files changed, 24 insertions(+), 2 deletions(-) create mode 100644 testsuite/tests/interpreter/user_fn_doc/script.lkql create mode 100644 testsuite/tests/interpreter/user_fn_doc/test.out create mode 100644 testsuite/tests/interpreter/user_fn_doc/test.yaml 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..9fed13287 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 @@ -1275,6 +1275,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 +1284,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/expressions/FunExpr.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/FunExpr.java index 73f2891f4..1e215a750 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.strip(); 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/testsuite/tests/interpreter/doc/script.lkql b/testsuite/tests/interpreter/doc/script.lkql index 4bab35237..d9d3e9eed 100644 --- a/testsuite/tests/interpreter/doc/script.lkql +++ b/testsuite/tests/interpreter/doc/script.lkql @@ -1,3 +1,8 @@ +fun user_fn() = + |" This is the docstring + 12 + print(print.doc) print(doc.doc) -print(children.doc) \ No newline at end of file +print(children.doc) +print(user_fn.doc) diff --git a/testsuite/tests/interpreter/doc/test.out b/testsuite/tests/interpreter/doc/test.out index 541c44f9d..795c58c24 100644 --- a/testsuite/tests/interpreter/doc/test.out +++ b/testsuite/tests/interpreter/doc/test.out @@ -2,3 +2,4 @@ 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 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' From 2a6d6c87a47d3fa609c0ea95cab9162619ccea78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 15 Dec 2023 09:27:10 +0100 Subject: [PATCH 04/14] Refactor built-ins registration --- .../com/adacore/lkql_jit/LKQLLanguage.java | 7 +- .../lkql_jit/built_ins/BuiltInFactory.java | 180 -------------- .../built_ins/BuiltInFunctionValue.java | 19 ++ .../lkql_jit/built_ins/BuiltInsHolder.java | 117 +++++++++ .../methods/AnalysisUnitMethods.java | 108 +++----- .../built_ins/methods/BoolMethods.java | 67 ----- .../built_ins/methods/BuiltInMethods.java | 48 ---- .../built_ins/methods/CommonMethods.java | 68 ----- .../built_ins/methods/FunctionMethods.java | 67 ----- .../built_ins/methods/IntMethods.java | 67 ----- .../built_ins/methods/IterableMethods.java | 45 ++-- .../built_ins/methods/LazyListMethods.java | 67 ----- .../built_ins/methods/ListMethods.java | 148 +++++------ .../built_ins/methods/NamespaceMethods.java | 67 ----- .../built_ins/methods/NodeMethods.java | 192 +++++---------- .../built_ins/methods/ObjectMethods.java | 67 ----- .../built_ins/methods/PropertyRefMethods.java | 67 ----- .../methods/SelectorListMethods.java | 67 ----- .../built_ins/methods/SelectorMethods.java | 67 ----- .../built_ins/methods/StrMethods.java | 232 +++++++----------- .../built_ins/methods/TokenMethods.java | 202 ++++++--------- .../built_ins/methods/TupleMethods.java | 67 ----- .../built_ins/methods/UnitMethods.java | 67 ----- .../passes/FramingPass.java | 16 +- .../adacore/lkql_jit/runtime/GlobalScope.java | 57 ++--- 25 files changed, 512 insertions(+), 1664 deletions(-) delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInFactory.java create mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInsHolder.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/BoolMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/BuiltInMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/CommonMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/FunctionMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/IntMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/LazyListMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/NamespaceMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/ObjectMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/PropertyRefMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/SelectorListMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/SelectorMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/TupleMethods.java delete mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/UnitMethods.java 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..d162528e5 --- /dev/null +++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/BuiltInsHolder.java @@ -0,0 +1,117 @@ +/*---------------------------------------------------------------------------- +-- 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(), + 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/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/IntMethods.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/IntMethods.java deleted file mode 100644 index c88c02b63..000000000 --- a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/methods/IntMethods.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 integer type in the LKQL language. - * - * @author Hugo GUERRIER - */ -public final class IntMethods extends CommonMethods { - - // ----- Attributes ----- - - /** The only instance of the method collection. */ - private static IntMethods instance = null; - - // ----- Constructors ----- - - /** Private constructor. */ - private IntMethods() { - super(); - } - - /** - * 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(); - } - return instance; - } - - // ----- Override methods ----- - - /** - * @see BuiltInMethods#getType() - */ - @Override - public String getType() { - return LKQLTypesHelper.LKQL_INTEGER; - } -} 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/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/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; } From ce5200bb6a4937c3d085184e5b151f3bf7e9e364 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 15 Dec 2023 10:44:12 +0100 Subject: [PATCH 05/14] Fix blockstring extraction --- .../passes/TranslationPass.java | 15 ++++++++++++--- .../lkql_jit/nodes/expressions/FunExpr.java | 2 +- .../tests/interpreter/block_strings/script.lkql | 4 ++++ .../tests/interpreter/block_strings/test.out | 2 ++ .../tests/interpreter/block_strings/test.yaml | 2 ++ .../invalid_block_string/script.lkql | 3 +++ .../invalid_block_string/test.out | 1 + .../invalid_block_string/test.yaml | 2 ++ user_manual/source/language_reference.rst | 8 ++++++-- 9 files changed, 33 insertions(+), 6 deletions(-) create mode 100644 testsuite/tests/interpreter/block_strings/script.lkql create mode 100644 testsuite/tests/interpreter/block_strings/test.out create mode 100644 testsuite/tests/interpreter/block_strings/test.yaml create mode 100644 testsuite/tests/interpreter_errors/invalid_block_string/script.lkql create mode 100644 testsuite/tests/interpreter_errors/invalid_block_string/test.out create mode 100644 testsuite/tests/interpreter_errors/invalid_block_string/test.yaml 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 9fed13287..4f80fb604 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 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 1e215a750..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 @@ -90,7 +90,7 @@ public FunExpr( this.parameterNames = new String[parameters.length]; this.parameterValues = new Expr[parameters.length]; this.body = body; - this.documentation = documentation.strip(); + this.documentation = documentation; this.initParams(parameters); } 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_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/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 From b1201628253a635c338f7f1933288a5a0615559a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 15 Dec 2023 14:42:06 +0100 Subject: [PATCH 06/14] Minor: typo fix --- .../com/adacore/lkql_jit/built_ins/values/LKQLFunction.java | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 1346f786e..abdebcad5 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 @@ -48,7 +48,7 @@ public class LKQLFunction extends BasicLKQLValue { /** The root node representing the function body. */ private final FunctionRootNode rootNode; - /** The closure for the function exercution. */ + /** The closure for the function execution. */ private final Closure closure; /** The name of the function. */ From 75bf30dc19fb8a095e91888d4ed5893050a4f0a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 15 Dec 2023 10:44:58 +0100 Subject: [PATCH 07/14] Pass over stdlib.lkql's docstrings Use ReST syntax where appropriate --- lkql_checker/share/lkql/stdlib.lkql | 48 ++++++++++++++++------------- 1 file changed, 27 insertions(+), 21 deletions(-) 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 From 3211cee069c8510a6e2f267745ed2df1c5be0c9f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 15 Dec 2023 10:45:49 +0100 Subject: [PATCH 08/14] Fix LKQL type names They'll end up in the doc at some stage so we don't want the Ada casing convention. --- .../java/com/adacore/lkql_jit/utils/LKQLTypesHelper.java | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) 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 ----- From 769d4948aad381ee933e99c552d11c8bb0dac141 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 15 Dec 2023 10:57:29 +0100 Subject: [PATCH 09/14] Store doc alongside namespace definition --- .../lkql_jit/built_ins/values/LKQLNamespace.java | 14 +++++++++++--- .../passes/TranslationPass.java | 9 ++++++++- .../com/adacore/lkql_jit/nodes/TopLevelList.java | 15 ++++++++++----- .../nodes/expressions/literals/StringLiteral.java | 2 +- 4 files changed, 30 insertions(+), 10 deletions(-) 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/langkit_translator/passes/TranslationPass.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/langkit_translator/passes/TranslationPass.java index 4f80fb604..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 @@ -206,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 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/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 ----- From dba60b4a0cce4624f9b861a1cb8c85e675b51854 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 15 Dec 2023 11:10:24 +0100 Subject: [PATCH 10/14] Refactor: Make most of LKQLFunction's fields public final --- .../built_ins/functions/MapFunction.java | 4 +-- .../functions/NodeCheckerFunction.java | 12 ++++---- .../built_ins/functions/ReduceFunction.java | 4 +-- .../functions/UnitCheckerFunction.java | 12 ++++---- .../built_ins/values/LKQLFunction.java | 28 ++++--------------- .../declarations/FunctionDeclaration.java | 2 +- .../lkql_jit/nodes/expressions/FunCall.java | 10 +++---- .../nodes/expressions/dot/DotAccess.java | 2 +- .../nodes/expressions/dot/SafeDotAccess.java | 2 +- 9 files changed, 28 insertions(+), 48 deletions(-) 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..fe5419ccf 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]); @@ -112,7 +112,7 @@ public Object executeGeneric(VirtualFrame frame) { res[i] = this.interopLibrary.execute( mapFunction, - mapFunction.getClosure().getContent(), + mapFunction.closure.getContent(), iterator.next()); } catch (ArityException | UnsupportedTypeException 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..2170c3bfc 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 @@ -278,13 +278,11 @@ private void applyNodeRule( : StringUtils.toLowerCase(aliasName)), StringUtils.toLowerCase(paramName)); arguments[i + 1] = - userDefinedArg == null - ? functionValue.getParameterDefaultValues()[i].executeGeneric(frame) - : userDefinedArg; + userDefinedArg == null ? 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..abc7e1e61 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 @@ -170,13 +170,11 @@ private void applyUnitRule( : StringUtils.toLowerCase(aliasName)), paramName); arguments[i + 1] = - userDefinedArg == null - ? functionValue.getParameterDefaultValues()[i].executeGeneric(frame) - : userDefinedArg; + userDefinedArg == null ? 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/values/LKQLFunction.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/values/LKQLFunction.java index abdebcad5..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 @@ -46,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 execution. */ - private final Closure closure; + 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 ----- @@ -95,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) { 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/dot/DotAccess.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/nodes/expressions/dot/DotAccess.java index b07555abf..57c5cfd0e 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 @@ -221,7 +221,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 From c53c0c37e4d8eee4ea61f7249066e6631079245f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 15 Dec 2023 11:39:07 +0100 Subject: [PATCH 11/14] Implement lkqlProfile on selectors --- .../com/adacore/lkql_jit/built_ins/values/LKQLSelector.java | 6 ++++++ testsuite/tests/interpreter/profile/script.lkql | 5 +++++ testsuite/tests/interpreter/profile/test.out | 1 + 3 files changed, 12 insertions(+) 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/testsuite/tests/interpreter/profile/script.lkql b/testsuite/tests/interpreter/profile/script.lkql index d714c6d20..e5ea4c8a0 100644 --- a/testsuite/tests/interpreter/profile/script.lkql +++ b/testsuite/tests/interpreter/profile/script.lkql @@ -1,2 +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 index 48fb76d3e..f0b5b899d 100644 --- a/testsuite/tests/interpreter/profile/test.out +++ b/testsuite/tests/interpreter/profile/test.out @@ -1 +1,2 @@ foo(a=12, b=(13, 14)) +bar() From d3eb2080e94688202b13841cda693e95b30b5f75 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 15 Dec 2023 14:26:40 +0100 Subject: [PATCH 12/14] Test doc(selector) & doc(namespace) --- testsuite/tests/interpreter/doc/script.lkql | 8 ++++++++ testsuite/tests/interpreter/doc/test.out | 2 ++ testsuite/tests/interpreter/doc/test_module.lkql | 3 +++ 3 files changed, 13 insertions(+) create mode 100644 testsuite/tests/interpreter/doc/test_module.lkql diff --git a/testsuite/tests/interpreter/doc/script.lkql b/testsuite/tests/interpreter/doc/script.lkql index d9d3e9eed..95e6ad460 100644 --- a/testsuite/tests/interpreter/doc/script.lkql +++ b/testsuite/tests/interpreter/doc/script.lkql @@ -1,8 +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) 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 795c58c24..06e339f05 100644 --- a/testsuite/tests/interpreter/doc/test.out +++ b/testsuite/tests/interpreter/doc/test.out @@ -3,3 +3,5 @@ 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 From 2d5d0350730d70ccd230ffff7b05019a04fbb7c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Fri, 15 Dec 2023 11:40:01 +0100 Subject: [PATCH 13/14] Implement java based LKQL doc generator Use it to build the doc. Get rid of ``generate_apidoc.py``, which is based on LKQL Ada and will thus disappear. --- Makefile | 4 +- .../lkql_jit/built_ins/BuiltInsHolder.java | 2 + .../built_ins/functions/DocumentBuiltins.java | 138 ++++++++ .../functions/DocumentNamespace.java | 124 +++++++ .../built_ins/functions/MapFunction.java | 4 +- .../functions/NodeCheckerFunction.java | 4 +- .../functions/UnitCheckerFunction.java | 4 +- .../nodes/expressions/dot/DotAccess.java | 5 +- .../adacore/lkql_jit/utils/TextWriter.java | 69 ++++ .../java/com/adacore/lkql_jit/LKQLDoc.java | 99 ++++++ .../java/com/adacore/lkql_jit/LKQLMain.java | 3 +- user_manual/Makefile | 2 +- user_manual/generate_apidoc.py | 192 ----------- user_manual/generated/std.rst | 303 ++++++++++++------ user_manual/generated/stdlib.rst | 111 +++---- 15 files changed, 700 insertions(+), 364 deletions(-) create mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/DocumentBuiltins.java create mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/built_ins/functions/DocumentNamespace.java create mode 100644 lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/TextWriter.java create mode 100644 lkql_jit/lkql_cli/src/main/java/com/adacore/lkql_jit/LKQLDoc.java delete mode 100644 user_manual/generate_apidoc.py diff --git a/Makefile b/Makefile index fade8eb18..75aa55d26 100644 --- a/Makefile +++ b/Makefile @@ -28,11 +28,11 @@ 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 lkql_checker lalcheck lkql_native_jit doc lkql: build/bin/liblkqllang_parse -doc: lkql +doc: lkql_native_jit cd user_manual && make clean html lkql_checker: lkql 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 index d162528e5..ca48f672c 100644 --- 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 @@ -48,6 +48,8 @@ public final class BuiltInsHolder { UniqueFunction.getValue(), DocFunction.getValue(), ProfileFunction.getValue(), + DocumentBuiltins.getValue(), + DocumentNamespace.getValue(), HelpFunction.getValue(), UnitsFunction.getValue(), SpecifiedUnitsFunction.getValue(), 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 fe5419ccf..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 @@ -111,9 +111,7 @@ public Object executeGeneric(VirtualFrame frame) { try { res[i] = this.interopLibrary.execute( - mapFunction, - mapFunction.closure.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 2170c3bfc..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 @@ -278,7 +278,9 @@ private void applyNodeRule( : StringUtils.toLowerCase(aliasName)), StringUtils.toLowerCase(paramName)); arguments[i + 1] = - userDefinedArg == null ? functionValue.parameterDefaultValues[i].executeGeneric(frame) : userDefinedArg; + userDefinedArg == null + ? functionValue.parameterDefaultValues[i].executeGeneric(frame) + : userDefinedArg; } // Place the closure in the arguments 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 abc7e1e61..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 @@ -170,7 +170,9 @@ private void applyUnitRule( : StringUtils.toLowerCase(aliasName)), paramName); arguments[i + 1] = - userDefinedArg == null ? functionValue.parameterDefaultValues[i].executeGeneric(frame) : userDefinedArg; + userDefinedArg == null + ? functionValue.parameterDefaultValues[i].executeGeneric(frame) + : userDefinedArg; } // Put the closure in the arguments 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 57c5cfd0e..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; diff --git a/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/TextWriter.java b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/TextWriter.java new file mode 100644 index 000000000..630185680 --- /dev/null +++ b/lkql_jit/language/src/main/java/com/adacore/lkql_jit/utils/TextWriter.java @@ -0,0 +1,69 @@ +/*---------------------------------------------------------------------------- +-- 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.utils; + +import java.io.IOException; +import java.io.Writer; + +public class TextWriter implements AutoCloseable { + + private int indent; + + private final Writer writer; + + public void withIndent(Runnable r) { + this.indent += 4; + r.run(); + this.indent -= 4; + } + + public TextWriter(Writer writer) { + this.writer = writer; + } + + 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); + } + } + + public void writeRaw(String str) throws IOException { + for (int i = 0; i < indent; i++) { + this.writer.write(" "); + } + this.writer.write(str); + } + + @Override + public void close() throws IOException { + this.writer.close(); + } +} 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/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. + From 20161fab037a7314b0bb5559264bc991874b60eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Mon, 13 Nov 2023 11:23:25 +0100 Subject: [PATCH 14/14] Get rid of LKQL Ada --- Makefile | 24 +- lkql/extensions/analysis/bodies | 33 - lkql/extensions/analysis/public_decls | 15 - lkql/extensions/mains/lkql_ada.adb | 155 -- lkql/extensions/nodes/lkql_node/components | 2 - lkql/extensions/src/funcs.adb | 67 - lkql/extensions/src/funcs.ads | 81 - lkql/extensions/src/iters-adapters.adb | 86 - lkql/extensions/src/iters-adapters.ads | 61 - lkql/extensions/src/iters-iterators.adb | 289 --- lkql/extensions/src/iters-iterators.ads | 198 -- lkql/extensions/src/iters-maps.adb | 94 - lkql/extensions/src/iters-maps.ads | 70 - lkql/extensions/src/iters-vec_iterators.adb | 73 - lkql/extensions/src/iters-vec_iterators.ads | 69 - lkql/extensions/src/iters.ads | 26 - .../liblkqllang-implementation-extensions.adb | 349 ---- .../liblkqllang-implementation-extensions.ads | 37 - lkql/extensions/src/liblkqllang-prelude.adb | 70 - lkql/extensions/src/liblkqllang-prelude.ads | 32 - .../extensions/src/lkql-adaptive_integers.adb | 274 --- .../extensions/src/lkql-adaptive_integers.ads | 85 - lkql/extensions/src/lkql-big_integers.adb | 233 --- lkql/extensions/src/lkql-big_integers.ads | 76 - .../extensions/src/lkql-builtin_functions.adb | 1610 ---------------- .../extensions/src/lkql-builtin_functions.ads | 44 - lkql/extensions/src/lkql-chained_pattern.adb | 303 --- lkql/extensions/src/lkql-chained_pattern.ads | 144 -- lkql/extensions/src/lkql-custom_selectors.adb | 328 ---- lkql/extensions/src/lkql-custom_selectors.ads | 106 -- lkql/extensions/src/lkql-depth_nodes.adb | 90 - lkql/extensions/src/lkql-depth_nodes.ads | 95 - lkql/extensions/src/lkql-error_handling.adb | 292 --- lkql/extensions/src/lkql-error_handling.ads | 182 -- lkql/extensions/src/lkql-errors.adb | 133 -- lkql/extensions/src/lkql-errors.ads | 94 - lkql/extensions/src/lkql-eval_contexts.adb | 632 ------ lkql/extensions/src/lkql-eval_contexts.ads | 305 --- lkql/extensions/src/lkql-evaluation.adb | 1295 ------------- lkql/extensions/src/lkql-evaluation.ads | 142 -- lkql/extensions/src/lkql-functions.adb | 522 ----- lkql/extensions/src/lkql-functions.ads | 42 - .../src/lkql-lk_nodes_iterators.adb | 188 -- .../src/lkql-lk_nodes_iterators.ads | 84 - lkql/extensions/src/lkql-node_data.adb | 419 ---- lkql/extensions/src/lkql-node_data.ads | 59 - lkql/extensions/src/lkql-node_extensions.adb | 48 - lkql/extensions/src/lkql-node_extensions.ads | 111 -- lkql/extensions/src/lkql-patterns-match.adb | 241 --- lkql/extensions/src/lkql-patterns-match.ads | 70 - lkql/extensions/src/lkql-patterns-nodes.adb | 406 ---- lkql/extensions/src/lkql-patterns-nodes.ads | 141 -- lkql/extensions/src/lkql-patterns.adb | 50 - lkql/extensions/src/lkql-patterns.ads | 65 - lkql/extensions/src/lkql-primitives.adb | 1688 ----------------- lkql/extensions/src/lkql-primitives.ads | 727 ------- lkql/extensions/src/lkql-queries.adb | 303 --- lkql/extensions/src/lkql-queries.ads | 83 - lkql/extensions/src/lkql-selector_lists.adb | 227 --- lkql/extensions/src/lkql-selector_lists.ads | 134 -- lkql/extensions/src/lkql-string_utils.adb | 148 -- lkql/extensions/src/lkql-string_utils.ads | 82 - lkql/extensions/src/lkql-unit_utils.adb | 364 ---- lkql/extensions/src/lkql-unit_utils.ads | 56 - lkql/extensions/src/lkql.adb | 47 - lkql/extensions/src/lkql.ads | 53 - lkql/extensions/src/options.adb | 57 - lkql/extensions/src/options.ads | 72 - lkql/extensions/src/unbounded_holders.adb | 102 - lkql/extensions/src/unbounded_holders.ads | 148 -- lkql/language/parser.py | 30 +- lkql/manage.py | 5 +- .../{lkql_checker.gpr => gnatcheck.gpr} | 10 +- lkql_checker/lalcheck.gpr | 30 - lkql_checker/src/checker_app.adb | 986 ---------- lkql_checker/src/checker_app.ads | 115 +- lkql_checker/src/exec.adb | 67 - lkql_checker/src/exec.ads | 46 - .../{lalcheck => src}/gnatcheck-compiler.adb | 0 .../{lalcheck => src}/gnatcheck-compiler.ads | 0 .../{lalcheck => src}/gnatcheck-diagnoses.adb | 0 .../{lalcheck => src}/gnatcheck-diagnoses.ads | 0 .../{lalcheck => src}/gnatcheck-ids.ads | 0 .../{lalcheck => src}/gnatcheck-options.ads | 0 .../{lalcheck => src}/gnatcheck-output.adb | 0 .../{lalcheck => src}/gnatcheck-output.ads | 0 .../gnatcheck-projects-aggregate.adb | 0 .../gnatcheck-projects-aggregate.ads | 0 .../{lalcheck => src}/gnatcheck-projects.adb | 0 .../{lalcheck => src}/gnatcheck-projects.ads | 0 .../gnatcheck-rules-rule_table.adb | 52 +- .../gnatcheck-rules-rule_table.ads | 1 + .../{lalcheck => src}/gnatcheck-rules.adb | 0 .../{lalcheck => src}/gnatcheck-rules.ads | 3 - .../gnatcheck-source_table.adb | 201 +- .../gnatcheck-source_table.ads | 9 +- .../gnatcheck-string_utilities.adb | 0 .../gnatcheck-string_utilities.ads | 0 lkql_checker/{lalcheck => src}/gnatcheck.ads | 0 .../lalcheck.adb => src/gnatcheck_main.adb} | 65 +- lkql_checker/src/lkql_checker.adb | 38 - lkql_checker/src/rule_commands.adb | 94 +- lkql_checker/src/rule_commands.ads | 18 +- lkql_checker/src/rules_factory.adb | 12 +- lkql_checker/src/rules_factory.ads | 8 +- 105 files changed, 86 insertions(+), 16735 deletions(-) delete mode 100644 lkql/extensions/analysis/bodies delete mode 100644 lkql/extensions/analysis/public_decls delete mode 100644 lkql/extensions/mains/lkql_ada.adb delete mode 100644 lkql/extensions/nodes/lkql_node/components delete mode 100644 lkql/extensions/src/funcs.adb delete mode 100644 lkql/extensions/src/funcs.ads delete mode 100644 lkql/extensions/src/iters-adapters.adb delete mode 100644 lkql/extensions/src/iters-adapters.ads delete mode 100644 lkql/extensions/src/iters-iterators.adb delete mode 100644 lkql/extensions/src/iters-iterators.ads delete mode 100644 lkql/extensions/src/iters-maps.adb delete mode 100644 lkql/extensions/src/iters-maps.ads delete mode 100644 lkql/extensions/src/iters-vec_iterators.adb delete mode 100644 lkql/extensions/src/iters-vec_iterators.ads delete mode 100644 lkql/extensions/src/iters.ads delete mode 100644 lkql/extensions/src/liblkqllang-implementation-extensions.adb delete mode 100644 lkql/extensions/src/liblkqllang-implementation-extensions.ads delete mode 100644 lkql/extensions/src/liblkqllang-prelude.adb delete mode 100644 lkql/extensions/src/liblkqllang-prelude.ads delete mode 100644 lkql/extensions/src/lkql-adaptive_integers.adb delete mode 100644 lkql/extensions/src/lkql-adaptive_integers.ads delete mode 100644 lkql/extensions/src/lkql-big_integers.adb delete mode 100644 lkql/extensions/src/lkql-big_integers.ads delete mode 100644 lkql/extensions/src/lkql-builtin_functions.adb delete mode 100644 lkql/extensions/src/lkql-builtin_functions.ads delete mode 100644 lkql/extensions/src/lkql-chained_pattern.adb delete mode 100644 lkql/extensions/src/lkql-chained_pattern.ads delete mode 100644 lkql/extensions/src/lkql-custom_selectors.adb delete mode 100644 lkql/extensions/src/lkql-custom_selectors.ads delete mode 100644 lkql/extensions/src/lkql-depth_nodes.adb delete mode 100644 lkql/extensions/src/lkql-depth_nodes.ads delete mode 100644 lkql/extensions/src/lkql-error_handling.adb delete mode 100644 lkql/extensions/src/lkql-error_handling.ads delete mode 100644 lkql/extensions/src/lkql-errors.adb delete mode 100644 lkql/extensions/src/lkql-errors.ads delete mode 100644 lkql/extensions/src/lkql-eval_contexts.adb delete mode 100644 lkql/extensions/src/lkql-eval_contexts.ads delete mode 100644 lkql/extensions/src/lkql-evaluation.adb delete mode 100644 lkql/extensions/src/lkql-evaluation.ads delete mode 100644 lkql/extensions/src/lkql-functions.adb delete mode 100644 lkql/extensions/src/lkql-functions.ads delete mode 100644 lkql/extensions/src/lkql-lk_nodes_iterators.adb delete mode 100644 lkql/extensions/src/lkql-lk_nodes_iterators.ads delete mode 100644 lkql/extensions/src/lkql-node_data.adb delete mode 100644 lkql/extensions/src/lkql-node_data.ads delete mode 100644 lkql/extensions/src/lkql-node_extensions.adb delete mode 100644 lkql/extensions/src/lkql-node_extensions.ads delete mode 100644 lkql/extensions/src/lkql-patterns-match.adb delete mode 100644 lkql/extensions/src/lkql-patterns-match.ads delete mode 100644 lkql/extensions/src/lkql-patterns-nodes.adb delete mode 100644 lkql/extensions/src/lkql-patterns-nodes.ads delete mode 100644 lkql/extensions/src/lkql-patterns.adb delete mode 100644 lkql/extensions/src/lkql-patterns.ads delete mode 100644 lkql/extensions/src/lkql-primitives.adb delete mode 100644 lkql/extensions/src/lkql-primitives.ads delete mode 100644 lkql/extensions/src/lkql-queries.adb delete mode 100644 lkql/extensions/src/lkql-queries.ads delete mode 100644 lkql/extensions/src/lkql-selector_lists.adb delete mode 100644 lkql/extensions/src/lkql-selector_lists.ads delete mode 100644 lkql/extensions/src/lkql-string_utils.adb delete mode 100644 lkql/extensions/src/lkql-string_utils.ads delete mode 100644 lkql/extensions/src/lkql-unit_utils.adb delete mode 100644 lkql/extensions/src/lkql-unit_utils.ads delete mode 100644 lkql/extensions/src/lkql.adb delete mode 100644 lkql/extensions/src/lkql.ads delete mode 100644 lkql/extensions/src/options.adb delete mode 100644 lkql/extensions/src/options.ads delete mode 100644 lkql/extensions/src/unbounded_holders.adb delete mode 100644 lkql/extensions/src/unbounded_holders.ads rename lkql_checker/{lkql_checker.gpr => gnatcheck.gpr} (78%) delete mode 100644 lkql_checker/lalcheck.gpr delete mode 100644 lkql_checker/src/checker_app.adb delete mode 100644 lkql_checker/src/exec.adb delete mode 100644 lkql_checker/src/exec.ads rename lkql_checker/{lalcheck => src}/gnatcheck-compiler.adb (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-compiler.ads (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-diagnoses.adb (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-diagnoses.ads (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-ids.ads (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-options.ads (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-output.adb (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-output.ads (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-projects-aggregate.adb (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-projects-aggregate.ads (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-projects.adb (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-projects.ads (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-rules-rule_table.adb (96%) rename lkql_checker/{lalcheck => src}/gnatcheck-rules-rule_table.ads (99%) rename lkql_checker/{lalcheck => src}/gnatcheck-rules.adb (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-rules.ads (99%) rename lkql_checker/{lalcheck => src}/gnatcheck-source_table.adb (90%) rename lkql_checker/{lalcheck => src}/gnatcheck-source_table.ads (98%) rename lkql_checker/{lalcheck => src}/gnatcheck-string_utilities.adb (100%) rename lkql_checker/{lalcheck => src}/gnatcheck-string_utilities.ads (100%) rename lkql_checker/{lalcheck => src}/gnatcheck.ads (100%) rename lkql_checker/{lalcheck/lalcheck.adb => src/gnatcheck_main.adb} (90%) delete mode 100644 lkql_checker/src/lkql_checker.adb diff --git a/Makefile b/Makefile index 75aa55d26..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 lkql_native_jit doc +all: lkql gnatcheck lkql_native_jit doc lkql: build/bin/liblkqllang_parse 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/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;