Skip to content

Instantly share code, notes, and snippets.

@philzook58
Last active Jan 6, 2022
Embed
What would you like to do?
primus lisp programmatic loading in bap
(executable
(name main)
;(modes byte js)
(flags -linkall -g)
; with dune build main.bc.js --release
; gets us to the Sys flushed error.
(js_of_ocaml (flags --toplevel --dynlink +toplevel.js +dynlink.js --disable inline --pretty --source-map-inline
--file /home/philip/.opam/bapjs/lib/bap/bil.plugin
--file /home/philip/.opam/bapjs/lib/bap/primus_lisp.plugin
--file /home/philip/Documents/ocaml/bapjs2/staticload/test.lisp
--file /home/philip/.opam/bapjs/share/bap/primus/lisp/core.lisp
--file /home/philip/.opam/bapjs/share/bap/primus/lisp/init.lisp
--file /home/philip/.opam/bapjs/share/bap/primus/lisp/memory.lisp
--file /home/philip/.opam/bapjs/share/bap/primus/lisp/pointers.lisp
)
(javascript_files helpers.js)
)
(libraries bap bap-primus zarith_stubs_js
; comment out for main.bc build
;js_of_ocaml-toplevel js_of_ocaml-ppx
)
;(preprocess (pps js_of_ocaml-ppx))
)
open Core_kernel
open Bap_primus.Std
open Bap.Std
open Bap_knowledge
open Bap_core_theory
include Self()
module KB = Knowledge
open KB.Syntax
let load_program paths features project =
match Primus.Lisp.Load.program ~paths project features with
| Ok prog -> prog
| Error err ->
let err = Format.asprintf "%a" Primus.Lisp.Load.pp_error err in
invalid_arg err
let (:=) p x v = KB.Value.put p v x
let empty = KB.Value.empty Theory.Source.cls
let pack prog = List.fold ~init:empty [
Theory.Source.language := Primus.Lisp.Unit.language;
Primus.Lisp.Semantics.program := prog;
] ~f:(|>)
let show target paths feat name =
Toplevel.try_exec @@ begin
Primus.Lisp.Unit.create target >>= fun unit ->
let prog = pack @@ load_program paths feat @@
Project.empty target in
KB.provide Theory.Unit.source unit prog >>= fun () ->
KB.Object.scoped Theory.Program.cls @@ fun obj ->
KB.sequence [
KB.provide Theory.Label.unit obj (Some unit);
KB.provide Primus.Lisp.Semantics.name obj (Some name);
] >>= fun () ->
KB.collect Theory.Semantics.slot obj >>| fun sema ->
Format.eprintf "%a@." KB.Value.pp sema
end
let () = match Bap_main.init
~log:(`Formatter Format.std_formatter) ~err:Format.std_formatter
with
| Ok () -> ()
| Error err -> Bap_main.Extension.Error.pp Format.std_formatter err
module Configuration = Bap_main.Extension.Configuration
let is_folder p = Sys.file_exists p && Sys.is_directory p
let library_paths =
let (/) = Filename.concat in Configuration.[
datadir / "primus" / "lisp";
sysdatadir / "primus" / "site-lisp";
sysdatadir / "primus" / "lisp";
] |> List.filter ~f:is_folder
let () = match show Theory.Target.unknown (library_paths @ ["."]) ["core"; "mytest"] (KB.Name.create "foo") with
| Ok () -> ()
| Error err -> (KB.Conflict.pp Format.std_formatter err); failwith "failed"
(defun foo (x) (set x (+ x 3)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment