adds bap primus-lisp-documentation (#1306)

Much like the old `bap --primus-lisp-documentation` this command
prints the Primus Lisp documentation in the .org format. But it
doesn't require a file as it is possible to specify the target using
the `--target` command line option.

Since `primus-lisp-documentation` is a separate command, it is not
necessary to specify a bogus file name and there are more options to
control the output. First of all, it is now possible to specify the
system (using `--system`), so that now it is possible to get the
documentation for symbolic primtives and functions. It is also
possible to set the package name (using `--package`) and request the
documentation for the Primus Lisp Semantics subsystem (with
`--semantics`).

Therefore, to get the documentation for thumb semantics (functions and
primitives), use

```
bap primus-lisp-documentation --semantics --package=thumb
```

The list of packages, along with their documentation is also available
in the `bap primus-lisp-documentation`

Author: ivg

lib/bap_primus/bap_primus.mli

@@ -3671,7 +3671,7 @@ text ::= ?any atom that is not recognized as a <word>?
         end
 
         module Category : Element
-        module Name     : Element
+        module Name     = Knowledge.Name
         module Descr    : Element
 
 
@@ -3988,6 +3988,13 @@ text ::= ?any atom that is not recognized as a <word>?
           ?types:Type.signature ->
           ?docs:string ->
           ?package:string -> string -> unit
+
+
+        (** [documentation unit] documentation for [unit]'s lisp source.
+
+            Typechecks and loads the unit lisp source and generates
+            its documentation. *)
+        val documentation : Theory.Unit.t -> Doc.index KB.t
       end
 
 

lib/bap_primus/bap_primus_lisp.ml

@@ -855,31 +855,44 @@ module Doc = struct
     Map.to_alist
 
   let describe prog item =
-    Lisp.Program.get prog item |> List.map ~f:(fun x ->
-        let name = Name.create (Lisp.Def.name x) in
-        let info = Info.create ~desc:(Lisp.Def.docs x) name in
-        name,Info.desc info) |> normalize
+    Lisp.Program.fold prog item ~init:[] ~f:(fun ~package def defs ->
+        let name = Name.create ~package (Lisp.Def.name def) in
+        let info = Info.create ~desc:(Lisp.Def.docs def) name in
+        (name,Info.desc info) :: defs) |> normalize
 
-  let index p = Lisp.Program.Items.[
+  let describe_packages prog =
+    Lisp.Program.packages prog |>
+    List.map ~f:(fun (n,d) -> KB.Name.create n, d)
+
+  let remove_empty = List.filter ~f:(function (_,[]) -> false | _ -> true)
+
+  let create_index p = remove_empty@@Lisp.Program.Items.[
+      "Packages", describe_packages p;
       "Macros", describe p macro;
       "Substitutions", describe p subst;
       "Constants", describe p const;
       "Functions", describe p func;
       "Methods", describe p meth;
       "Parameters", describe p para;
       "Primitives", describe p primitive;
+      "Primitives", describe p semantics;
       "Signals", describe p signal;
     ]
 
   module Make(Machine : Machine) = struct
     open Machine.Syntax
     let generate_index : index Machine.t =
       Machine.Local.get state >>| fun s ->
-      index s.program
+      create_index s.program
   end
 end
 
 let primitive = lisp_primitive
-module Semantics = Bap_primus_lisp_semantics
+module Semantics = struct
+  include Bap_primus_lisp_semantics
+  let documentation unit =
+    KB.Syntax.(typed_program unit >>| Doc.create_index)
+end
+
 module Unit = Semantics.Unit
 module Attribute = Lisp.Attribute

lib/bap_primus/bap_primus_lisp.mli

@@ -22,7 +22,7 @@ module Doc : sig
   end
 
   module Category : Element
-  module Name     : Element
+  module Name     = KB.Name
   module Descr    : Element
   type index = (Category.t * (Name.t * Descr.t) list) list
 
@@ -155,6 +155,7 @@ module Semantics : sig
     ?types:Type.signature ->
     ?docs:string -> ?package:string -> string -> unit
 
+  val documentation : Theory.Unit.t -> Doc.index KB.t
 end
 
 module Unit : sig

lib/bap_primus/bap_primus_lisp_parse.ml

@@ -68,7 +68,7 @@ let is_quoted s =
 let is_symbol s =
   String.length s > 1 && Char.(s.[0] = '\'')
 
-let unqoute s =
+let unquote s =
   if is_quoted s
   then String.sub ~pos:1 ~len:(String.length s - 2) s
   else s
@@ -107,7 +107,7 @@ module Parse = struct
       | Ok var -> var
 
   let fmt prog fmt tree =
-    let fmt = unqoute fmt in
+    let fmt = unquote fmt in
     let fail err off =
       let pos =
         Loc.nth_char (loc (Program.sources prog) [tree]) (off+1) in
@@ -355,8 +355,8 @@ module Parse = struct
     List.fold ~init:prog trees ~f:(fun prog -> function
         | {data=List ({data=Atom ":use"} :: packages)} ->
           use_package ~package:name prog packages
-        | {data=List ({data=Atom ":documentation"} :: _)} ->
-          prog
+        | {data=List [{data=Atom ":documentation"}; {data=Atom docs}]} ->
+          Program.update_package_documentation prog name (unquote docs)
         | s -> fail (Bad_def Defpkg) s)
 
   let toplevels = String.Set.of_list [

lib/bap_primus/bap_primus_lisp_program.ml

@@ -36,6 +36,7 @@ type t = {
   sources : Source.t;
   exports : Set.M(String).t Map.M(String).t;
   library : package Map.M(String).t;
+  pkgdocs : string Map.M(String).t;
 } [@@deriving fields]
 
 type program = t
@@ -61,6 +62,7 @@ let empty = {
   package = default_package;
   exports = Map.empty (module String);
   library = Map.empty (module String);
+  pkgdocs = Map.empty (module String);
 }
 
 let with_package program package = {program with package}
@@ -146,6 +148,16 @@ let merge_packages p1 p2 = {
   places = p1.places ++ p2.places;
 }
 
+let update_package_documentation prog package docs = {
+  prog with pkgdocs = Map.set prog.pkgdocs package docs;
+}
+
+let packages {library; pkgdocs} =
+  Map.keys library |>
+  List.map ~f:(fun pkg -> pkg, match Map.find pkgdocs pkg with
+    | None -> ""
+    | Some docs -> docs)
+
 let use_package program ?(target=program.package) from =
   let program = {
     program with
@@ -169,6 +181,14 @@ let equal p1 p2 =
 
 let is_empty p = Map.is_empty p.library
 
+let merge_pkgdocs =
+  Map.merge ~f:(fun ~key:_ -> function
+      | `Left docs | `Right docs -> Some docs
+      | `Both ("","") -> Some ""
+      | `Both (d,"")
+      | `Both ("",d) -> Some d
+      | `Both (d1,_) -> Some d1)
+
 let merge_libraries l1 l2 =
   Map.merge_skewed l1 l2 ~combine:(fun ~key:_ -> merge_packages)
 
@@ -181,14 +201,14 @@ let reexport program =
 
 let merge p1 p2 = reexport {
     p1 with
+    pkgdocs = merge_pkgdocs p1.pkgdocs p2.pkgdocs;
     sources = p2.sources;
     context = Lisp.Context.merge p1.context p2.context;
     library = merge_libraries p1.library p2.library;
     exports = Map.merge_skewed p1.exports p2.exports
         ~combine:(fun ~key:_ -> Set.union)
   }
 
-
 type full_access = [`Read | `Set_and_create ]
 type 'a item =
   (full_access, package, 'a Def.t list) Fieldslib.Field.t_with_perm
@@ -1537,7 +1557,7 @@ the inferred type of the method:@\n%a"
       | No_unification (x,t1,y,t2) ->
         fprintf ppf "
 Type error: expected %a got %a. Details follow, the expression:
-%ahas type %a, but it is expected to have type %a after its unification
+%a has type %a, but it is expected to have type %a after its unification
 with the expression:@\n%a@\n"
           pp_val t1 pp_val t2
           pp_exp (sources,x) pp_val t1 pp_val t2 pp_exp (sources,y)

lib/bap_primus/bap_primus_lisp_program.mli

@@ -28,7 +28,8 @@ val with_package : t -> string -> t
 val reset_package : t -> t
 val use_package : t -> ?target:string -> string -> t
 val in_package : string -> t -> (t -> 'a) -> 'a
-
+val packages : t -> (string * string) list
+val update_package_documentation : t -> string -> string -> t
 val is_applicable : t -> 'a Def.t -> bool
 
 module Items : sig

lib/bap_primus/bap_primus_lisp_semantics.ml

@@ -160,9 +160,6 @@ let static_slot =
     ~equal:Bitvec.equal
     ~inspect:(fun x -> Sexp.Atom (Bitvec.to_string x))
 
-
-
-
 let update_value r f =
   let v = KB.Value.get Theory.Semantics.value r in
   KB.Value.put Theory.Semantics.value r (f v)
@@ -645,6 +642,12 @@ let obtain_typed_program unit =
       program
     | errs -> KB.fail (Illtyped_program errs)
 
+
+let typed_program unit =
+  let open KB.Syntax in
+  obtain_typed_program unit >>| fun {prog} -> prog
+
+
 let provide_semantics ?(stdout=Format.std_formatter) () =
   let open KB.Syntax in
   KB.Rule.(begin

lib/bap_primus/bap_primus_lisp_semantics.mli

@@ -15,6 +15,8 @@ val symbol : (Theory.Value.cls, String.t option) KB.slot
 val static : (Theory.Value.cls, Bitvec.t option) KB.slot
 val enable : ?stdout:Format.formatter -> unit -> unit
 
+val typed_program : Theory.Unit.t -> program KB.t
+
 val declare :
   ?types:(Theory.Target.t -> Bap_primus_lisp_type.signature) ->
   ?docs:string ->

lib/knowledge/bap_knowledge.ml

@@ -3071,7 +3071,8 @@ module Knowledge = struct
     module Make() = struct
       type t = Name.t [@@deriving bin_io, sexp]
 
-      let elements = Hash_set.create (module Name)
+      let unknown = Name.of_string ":unknown"
+      let elements = Hash_set.of_list (module Name) [unknown]
       let declare ?package name =
         let name = Name.create ?package name in
         if Hash_set.mem elements name
@@ -3089,7 +3090,6 @@ module Knowledge = struct
         name
 
       let name x = x
-      let unknown = Name.of_string ":unknown"
       let is_unknown = Name.equal unknown
       let hash = Name.hash
       let members () = Hash_set.to_list elements

oasis/primus-lisp

@@ -16,7 +16,8 @@ Library primus_lisp_library_plugin
                    Primus_lisp_ieee754,
                    Primus_lisp_io,
                    Primus_lisp_show,
-                   Primus_lisp_run
+                   Primus_lisp_run,
+                   Primus_lisp_documentation
   XMETADescription: install and load Primus lisp libraries
   DataFiles:        lisp/*.lisp ($datadir/bap/primus/lisp),
                     site-lisp/*.lisp ($datadir/bap/primus/site-lisp),