From 90df7f9c832eb580eb00b92485000f62350864ec Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Wed, 17 Jun 2020 09:34:59 +0200
Subject: [PATCH] [server] kernel ast
---
src/plugins/server/Makefile.in | 2 +-
src/plugins/server/kernel_ast.ml | 155 +++++++++++++++++-------------
src/plugins/server/kernel_ast.mli | 10 ++
src/plugins/server/kernel_main.ml | 65 ++++++-------
src/plugins/server/states.ml | 12 +--
5 files changed, 138 insertions(+), 106 deletions(-)
diff --git a/src/plugins/server/Makefile.in b/src/plugins/server/Makefile.in
index e64141111ed..afbeaab28a9 100644
--- a/src/plugins/server/Makefile.in
+++ b/src/plugins/server/Makefile.in
@@ -46,7 +46,7 @@ PLUGIN_CMO:= \
server_batch \
kernel_main \
kernel_project \
-# kernel_ast \
+ kernel_ast \
# kernel_properties
PLUGIN_DISTRIBUTED:=$(PLUGIN_ENABLE)
diff --git a/src/plugins/server/kernel_ast.ml b/src/plugins/server/kernel_ast.ml
index 42ad8845ffb..07a1a7a2f6c 100644
--- a/src/plugins/server/kernel_ast.ml
+++ b/src/plugins/server/kernel_ast.ml
@@ -21,19 +21,19 @@
(**************************************************************************)
open Data
-module Sy = Syntax
module Md = Markdown
module Js = Yojson.Basic.Util
+module Pkg = Package
open Cil_types
-let page = Server_doc.page `Kernel ~title:"Ast Services" ~filename:"ast.md" ()
+let package = Pkg.package ~title:"Ast Services" ~name:"ast" ()
(* -------------------------------------------------------------------------- *)
(* --- Compute Ast --- *)
(* -------------------------------------------------------------------------- *)
-let () = Request.register ~page
- ~kind:`EXEC ~name:"kernel.ast.compute"
+let () = Request.register ~package
+ ~kind:`EXEC ~name:"compute"
~descr:(Md.plain "Ensures that AST is computed")
~input:(module Junit) ~output:(module Junit) Ast.compute
@@ -43,11 +43,12 @@ let () = Request.register ~page
(* The kind of a marker. *)
module MarkerKind = struct
- let t =
- Enum.dictionary ~page ~name:"markerkind" ~title:"Marker kind"
- ~descr:(Md.plain "Marker kind") ()
- let kind name = Enum.tag t ~name ~descr:(Md.plain name) ()
+ let kinds = Enum.dictionary ()
+
+ let kind name = Enum.tag ~name
+ ~descr:(Md.plain (String.capitalize_ascii name)) kinds
+
let expr = kind "expression"
let lval = kind "lvalue"
let var = kind "variable"
@@ -58,21 +59,25 @@ module MarkerKind = struct
let term = kind "term"
let prop = kind "property"
- let tag =
- let open Printer_tag in
- function
- | PStmt _ -> stmt
- | PStmtStart _ -> stmt
- | PVDecl _ -> decl
- | PLval (_, _, (Var vi, NoOffset)) ->
- if Cil.isFunctionType vi.vtype then fct else var
- | PLval _ -> lval
- | PExp _ -> expr
- | PTermLval _ -> term
- | PGlobal _ -> glob
- | PIP _ -> prop
-
- let data = Enum.publish t ~tag ()
+ let () = Enum.set_lookup kinds
+ begin
+ let open Printer_tag in
+ function
+ | PStmt _ -> stmt
+ | PStmtStart _ -> stmt
+ | PVDecl _ -> decl
+ | PLval (_, _, (Var vi, NoOffset)) ->
+ if Cil.isFunctionType vi.vtype then fct else var
+ | PLval _ -> lval
+ | PExp _ -> expr
+ | PTermLval _ -> term
+ | PGlobal _ -> glob
+ | PIP _ -> prop
+ end
+
+ let data = Request.dictionary ~package
+ ~name:"markerKind" ~descr:(Md.plain "Marker kind") kinds
+
include (val data : S with type t = Printer_tag.localizable)
end
@@ -116,33 +121,33 @@ struct
let array =
let model = States.model () in
let () =
- States.column ~model
+ States.column
~name:"kind" ~descr:(Md.plain "Marker kind")
- ~data:(module MarkerKind) ~get:fst ()
+ ~data:(module MarkerKind) ~get:fst
+ model
in
let () =
- States.column ~model
+ States.column
~name:"name"
~descr:(Md.plain "Marker short name")
~data:(module Jstring)
~get:(fun (tag, _) -> Printer_tag.label tag)
- ()
+ model
in
let () =
- States.column ~model
+ States.column
~name:"descr"
~descr:(Md.plain "Marker declaration or description")
~data:(module Jstring)
~get:(fun (tag, _) -> Rich_text.to_string Printer_tag.pretty tag)
- ()
+ model
in
States.register_array
- ~page
- ~name:"kernel.ast.markerKind"
+ ~package
+ ~name:"markerKind"
~descr:(Md.plain "Kind of markers")
~key:snd
- ~iter
- model
+ ~iter model
let create_tag = function
| PStmt(_,s) -> Printf.sprintf "#s%d" s.sid
@@ -167,10 +172,22 @@ struct
let lookup tag = Hashtbl.find (STATE.get()).locs tag
type t = localizable
- let syntax = Sy.publish ~page:Data.page ~name:"marker"
- ~synopsis:Sy.ident
- ~descr:(Md.plain "Localizable AST marker \
- (function, globals, statements, properties, etc.)") ()
+
+ let markers = ref []
+ let jmarker kd =
+ let jt = Pkg.Jkey kd in markers := jt :: !markers ; jt
+
+ let jstmt = jmarker "stmt"
+ let jdecl = jmarker "decl"
+ let jllet = jmarker "llet"
+ let jexpr = jmarker "expr"
+ let jterm = jmarker "term"
+ let jglobal = jmarker "global"
+ let jproperty = jmarker "property"
+
+ let jtype = Pkg.datatype ~package ~name:"marker"
+ ~descr:(Md.plain "Localizable AST markers")
+ Pkg.(Junion (List.rev !markers))
let to_json loc = `String (create loc)
let of_json js =
@@ -188,9 +205,7 @@ module Printer = Printer_tag.Make(Marker)
module Stmt = Data.Collection
(struct
type t = stmt
- let syntax = Sy.publish ~page:Data.page ~name:"stmt"
- ~synopsis:Sy.ident
- ~descr:(Md.plain "Code statement identifier") ()
+ let jtype = Marker.jstmt
let to_json st =
let kf = Kernel_function.find_englobing_kf st in
Marker.to_json (PStmt(kf,st))
@@ -204,21 +219,19 @@ module Stmt = Data.Collection
module Ki = Data.Collection
(struct
type t = kinstr
- let syntax = Sy.union [ Sy.tag "global" ; Stmt.syntax ]
+ let jtype = Pkg.Joption Marker.jstmt
let to_json = function
- | Kglobal -> `String "global"
+ | Kglobal -> `Null
| Kstmt st -> Stmt.to_json st
let of_json = function
- | `String "global" -> Kglobal
+ | `Null -> Kglobal
| js -> Kstmt (Stmt.of_json js)
end)
module Kf = Data.Collection
(struct
type t = kernel_function
- let syntax = Sy.publish ~page:Data.page ~name:"fct-id"
- ~synopsis:Sy.ident
- ~descr:(Md.plain "Function identified by its global name.") ()
+ let jtype = Pkg.Jkey "fct"
let to_json kf =
`String (Kernel_function.get_name kf)
let of_json js =
@@ -231,8 +244,18 @@ module Kf = Data.Collection
(* --- Functions --- *)
(* -------------------------------------------------------------------------- *)
-let () = Request.register ~page
- ~kind:`GET ~name:"kernel.ast.printFunction"
+let () = Request.register ~package
+ ~kind:`GET ~name:"getFunctions"
+ ~descr:(Md.plain "Collect all functions in the AST")
+ ~input:(module Junit) ~output:(module Kf.Jlist)
+ begin fun () ->
+ let pool = ref [] in
+ Globals.Functions.iter (fun kf -> pool := kf :: !pool) ;
+ List.rev !pool
+ end
+
+let () = Request.register ~package
+ ~kind:`GET ~name:"printFunction"
~descr:(Md.plain "Print the AST of a function")
~input:(module Kf) ~output:(module Jtext)
(fun kf -> Jbuffer.to_json Printer.pp_global (Kernel_function.get_global kf))
@@ -249,24 +272,22 @@ struct
let array : kernel_function States.array =
begin
let model = States.model () in
- States.column ~model
+ States.column model
~name:"name"
~descr:(Md.plain "Name")
~data:(module Data.Jstring)
- ~get:Kernel_function.get_name () ;
- States.column ~model
+ ~get:Kernel_function.get_name ;
+ States.column model
~name:"signature"
~descr:(Md.plain "Signature")
~data:(module Data.Jstring)
- ~get:signature
- () ;
- States.register_array
- ~page ~key
- ~name:"kernel.ast.functions"
+ ~get:signature ;
+ States.register_array model
+ ~package ~key
+ ~name:"functions"
~descr:(Md.plain "AST Functions")
~iter:Globals.Functions.iter
- ~add_reload_hook:Ast.add_hook_on_update
- model
+ ~add_reload_hook:Ast.add_hook_on_update ;
end
end
@@ -335,8 +356,8 @@ module Info = struct
Jbuffer.contents buffer
end
-let () = Request.register ~page
- ~kind:`GET ~name:"kernel.ast.info"
+let () = Request.register ~package
+ ~kind:`GET ~name:"getInfo"
~descr:(Md.plain "Get textual information about a marker")
~input:(module Marker) ~output:(module Jtext)
Info.get_marker_info
@@ -351,10 +372,10 @@ let get_files () =
let () =
Request.register
- ~page
+ ~package
~descr:(Md.plain "Get the currently analyzed source file names")
~kind:`GET
- ~name:"kernel.ast.getFiles"
+ ~name:"getFiles"
~input:(module Junit) ~output:(module Jstring.Jlist)
get_files
@@ -364,24 +385,26 @@ let set_files files =
let () =
Request.register
- ~page
+ ~package
~descr:(Md.plain "Set the source file names to analyze.")
~kind:`SET
- ~name:"kernel.ast.setFiles"
+ ~name:"setFiles"
~input:(module Jstring.Jlist)
~output:(module Junit)
set_files
+(*
let () =
Request.register
- ~page
+ ~package
~descr:(Md.plain "Compute the AST of the currently set source file names.")
~kind:`EXEC
- ~name:"kernel.ast.execCompute"
+ ~name:"kernel.execCompute"
~input:(module Junit)
~output:(module Junit)
(fun () ->
if not (Ast.is_computed ())
then File.init_from_cmdline ())
+*)
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/kernel_ast.mli b/src/plugins/server/kernel_ast.mli
index 79b5a4eee57..9130d0cf913 100644
--- a/src/plugins/server/kernel_ast.mli
+++ b/src/plugins/server/kernel_ast.mli
@@ -24,6 +24,7 @@
(** Ast Data *)
(* -------------------------------------------------------------------------- *)
+open Package
open Cil_types
module Kf : Data.S_collection with type t = kernel_function
@@ -33,6 +34,15 @@ module Stmt : Data.S_collection with type t = stmt
module Marker :
sig
include Data.S with type t = Printer_tag.localizable
+
+ val jstmt : jtype
+ val jdecl : jtype
+ val jllet : jtype
+ val jexpr : jtype
+ val jterm : jtype
+ val jglobal : jtype
+ val jproperty : jtype
+
val create : t -> string (** Memoized unique identifier. *)
val lookup : string -> t (** Get back the localizable, if any. *)
end
diff --git a/src/plugins/server/kernel_main.ml b/src/plugins/server/kernel_main.ml
index ad3e9fd94b8..6e7751be31e 100644
--- a/src/plugins/server/kernel_main.ml
+++ b/src/plugins/server/kernel_main.ml
@@ -114,38 +114,37 @@ module LogSource = Collection
(* --- Log Lind --- *)
(* -------------------------------------------------------------------------- *)
-module LogKind = Collection
- (struct
-
- let kinds = Enum.dictionary ()
-
- let t_kind value name descr =
- Enum.tag ~name ~descr:(Md.plain descr) ~value kinds
-
- let t_error = t_kind Log.Error "ERROR" "User Error"
- let t_warning = t_kind Log.Warning "WARNING" "User Warning"
- let t_feedback = t_kind Log.Feedback "FEEDBACK" "Plugin Feedback"
- let t_result = t_kind Log.Result "RESULT" "Plugin Result"
- let t_failure = t_kind Log.Failure "FAILURE" "Plugin Failure"
- let t_debug = t_kind Log.Debug "DEBUG" "Analyser Debug"
-
- let () = Enum.set_lookup kinds
- begin function
- | Log.Error -> t_error
- | Log.Warning -> t_warning
- | Log.Feedback -> t_feedback
- | Log.Result -> t_result
- | Log.Failure -> t_failure
- | Log.Debug -> t_debug
- end
-
- let data = Request.dictionary ~package
- ~name:"logkind"
- ~descr:(Md.plain "Log messages categories.")
- kinds
-
- include (val data : S with type t = Log.kind)
- end)
+module LogKind =
+struct
+ let kinds = Enum.dictionary ()
+
+ let t_kind value name descr =
+ Enum.tag ~name ~descr:(Md.plain descr) ~value kinds
+
+ let t_error = t_kind Log.Error "ERROR" "User Error"
+ let t_warning = t_kind Log.Warning "WARNING" "User Warning"
+ let t_feedback = t_kind Log.Feedback "FEEDBACK" "Plugin Feedback"
+ let t_result = t_kind Log.Result "RESULT" "Plugin Result"
+ let t_failure = t_kind Log.Failure "FAILURE" "Plugin Failure"
+ let t_debug = t_kind Log.Debug "DEBUG" "Analyser Debug"
+
+ let () = Enum.set_lookup kinds
+ begin function
+ | Log.Error -> t_error
+ | Log.Warning -> t_warning
+ | Log.Feedback -> t_feedback
+ | Log.Result -> t_result
+ | Log.Failure -> t_failure
+ | Log.Debug -> t_debug
+ end
+
+ let data = Request.dictionary ~package
+ ~name:"logkind"
+ ~descr:(Md.plain "Log messages categories.")
+ kinds
+
+ include (val data : S with type t = Log.kind)
+end
(* -------------------------------------------------------------------------- *)
(* --- Log Events --- *)
@@ -170,7 +169,7 @@ module LogEvent = Collection
~descr:(Md.plain "Source file position") (module LogSource)
let data = Record.publish ~package ~name:"log"
- ~descr:(Md.plain "Message event record.") jlog
+ ~descr:(Md.plain "Message event record.") jlog
module R : Record.S with type r = rlog = (val data)
diff --git a/src/plugins/server/states.ml b/src/plugins/server/states.ml
index d2b486c50e3..c238dcd7aca 100644
--- a/src/plugins/server/states.ml
+++ b/src/plugins/server/states.ml
@@ -289,13 +289,13 @@ let register_array ~package ~name ~descr ~key
} in
let signature = Request.signature () in
let module Jkeys = Jlist(struct
- include Jstring
- let jtype = Package.Jkey name
- end) in
+ include Jstring
+ let jtype = Package.Jkey name
+ end) in
let module Jrows = Jlist (struct
- include Jany
- let jtype = Package.Jdata row
- end) in
+ include Jany
+ let jtype = Package.Jdata row
+ end) in
let set_reload = Request.result signature
~name:"reload" ~descr:(plain "array fully reloaded")
(module Jbool) in
--
GitLab