diff --git a/compiler/lib/build_info.ml b/compiler/lib/build_info.ml index 66b0e4b442..9d733c91ba 100644 --- a/compiler/lib/build_info.ml +++ b/compiler/lib/build_info.ml @@ -90,6 +90,20 @@ let parse s = in Some t +let to_sexp info = + Sexp.List + (info + |> StringMap.bindings + |> List.map ~f:(fun (k, v) -> Sexp.List [ Atom k; Atom v ])) + +let from_sexp info = + let open Sexp.Util in + info + |> assoc + |> List.fold_left + ~f:(fun m (k, v) -> StringMap.add k (single string v) m) + ~init:StringMap.empty + exception Incompatible_build_info of { key : string diff --git a/compiler/lib/build_info.mli b/compiler/lib/build_info.mli index 9bb1254a78..34c72abbc5 100644 --- a/compiler/lib/build_info.mli +++ b/compiler/lib/build_info.mli @@ -34,6 +34,10 @@ val to_string : t -> string val parse : string -> t option +val to_sexp : t -> Sexp.t + +val from_sexp : Sexp.t -> t + val with_kind : t -> kind -> t exception diff --git a/compiler/lib/sexp.ml b/compiler/lib/sexp.ml new file mode 100644 index 0000000000..046e6d67f5 --- /dev/null +++ b/compiler/lib/sexp.ml @@ -0,0 +1,161 @@ +(* ()#;"" space <-- reserved *) +open Stdlib + +type t = + | Atom of string + | List of t list + +let reserved_char c = + match c with + | '\x00' .. ' ' | '(' | ')' | '#' | ';' | '"' | '\x7f' .. '\xff' -> true + | _ -> false + +let need_escaping s = + let len = String.length s in + len = 0 + || + let res = ref false in + for i = 0 to len - 1 do + res := !res || reserved_char s.[i] + done; + !res + +let should_quote c = + match c with + | '\x00' .. '\x1F' | '"' | '\\' | '\x7f' .. '\xff' -> true + | _ -> false + +let escape_to_buffer buf s = + let start = ref 0 in + let len = String.length s in + Buffer.add_char buf '"'; + for i = 0 to len - 1 do + let c = s.[i] in + if should_quote c + then ( + if !start < i then Buffer.add_substring buf s !start (i - !start); + Buffer.add_char buf '\\'; + let c = Char.code c in + Buffer.add_uint8 buf ((c / 100) + 48); + Buffer.add_uint8 buf ((c / 10 mod 10) + 48); + Buffer.add_uint8 buf ((c mod 10) + 48); + start := i + 1) + done; + if !start < len then Buffer.add_substring buf s !start (len - !start); + Buffer.add_char buf '"' + +let rec add_to_buffer buf v = + match v with + | Atom s -> if need_escaping s then escape_to_buffer buf s else Buffer.add_string buf s + | List l -> + Buffer.add_char buf '('; + List.iteri + ~f:(fun i v' -> + if i > 0 then Buffer.add_char buf ' '; + add_to_buffer buf v') + l; + Buffer.add_char buf ')' + +let to_string v = + let b = Buffer.create 128 in + add_to_buffer b v; + Buffer.contents b + +let parse_error () = failwith "parse error" + +let rec parse buf s pos : t * int = + match s.[pos] with + | '(' -> parse_list buf s [] (pos + 1) + | '\"' -> + Buffer.clear buf; + parse_quoted_atom buf s (pos + 1) (pos + 1) + | _ -> parse_atom buf s pos pos + +and parse_list buf s acc pos = + match s.[pos] with + | ' ' -> parse_list buf s acc (pos + 1) + | ')' -> List (List.rev acc), pos + 1 + | _ -> + let v, pos' = parse buf s pos in + parse_list buf s (v :: acc) pos' + +and parse_atom buf s pos0 pos = + if reserved_char s.[pos] + then ( + if pos0 = pos then parse_error (); + Atom (String.sub s ~pos:pos0 ~len:(pos - pos0)), pos) + else parse_atom buf s pos0 (pos + 1) + +and parse_quoted_atom buf s pos0 pos = + match s.[pos] with + | '\"' -> + if pos0 < pos then Buffer.add_substring buf s pos0 (pos - pos0); + Atom (Buffer.contents buf), pos + 1 + | '\\' -> + if pos0 < pos then Buffer.add_substring buf s pos0 (pos - pos0); + Buffer.add_uint8 + buf + (((Char.code s.[pos + 1] - 48) * 100) + + ((Char.code s.[pos + 2] - 48) * 10) + + Char.code s.[pos + 3] + - 48); + parse_quoted_atom buf s (pos + 4) (pos + 4) + | _ -> parse_quoted_atom buf s pos0 (pos + 1) + +let from_string s = + let v, pos = parse (Buffer.create 16) s 0 in + if pos < String.length s then parse_error (); + v + +module Util = struct + let single f v = + match v with + | [ v ] -> f v + | _ -> assert false + + let string v = + match v with + | Atom s -> s + | _ -> assert false + + let assoc v = + match v with + | List l -> + List.map + ~f:(fun p -> + match p with + | List (Atom k :: v) -> k, v + | _ -> assert false) + l + | Atom _ -> assert false + + let member nm v = + match v with + | Atom _ -> assert false + | List l -> + List.find_map + ~f:(fun p -> + match p with + | List (Atom nm' :: v) when String.equal nm nm' -> Some v + | _ -> None) + l + + let bool v = + match v with + | Atom "true" -> true + | Atom "false" -> false + | _ -> assert false + + let mandatory f v = + match v with + | Some v -> f v + | None -> assert false +end +(* +parse + (to_string + (List + [ List [ Atom "provides"; Atom "toto" ] + ; List [ Atom "requires"; Atom "foo"; Atom "bar"; Atom "foo\n bar" ] + ])) +*) diff --git a/compiler/lib/sexp.mli b/compiler/lib/sexp.mli new file mode 100644 index 0000000000..c0a6cb404b --- /dev/null +++ b/compiler/lib/sexp.mli @@ -0,0 +1,21 @@ +type t = + | Atom of string + | List of t list + +val to_string : t -> string + +val from_string : string -> t + +module Util : sig + val single : (t -> 'a) -> t list -> 'a + + val mandatory : (t list -> 'a) -> t list option -> 'a + + val string : t -> string + + val bool : t -> bool + + val assoc : t -> (string * t list) list + + val member : string -> t -> t list option +end diff --git a/compiler/lib/unit_info.ml b/compiler/lib/unit_info.ml index 9449b7f656..4ec0e151fb 100644 --- a/compiler/lib/unit_info.ml +++ b/compiler/lib/unit_info.ml @@ -150,3 +150,43 @@ let parse acc s = | Some ("Effects_without_cps", b) -> Some { acc with effects_without_cps = bool_of_string (String.trim b) } | Some (_, _) -> None) + +let to_sexp t = + let add nm skip v rem = if skip then rem else Sexp.List (Atom nm :: v) :: rem in + let set nm f rem = + add + nm + (List.equal ~eq:String.equal (f empty) (f t)) + (List.map ~f:(fun x -> Sexp.Atom x) (f t)) + rem + in + let bool nm f rem = + add + nm + (Bool.equal (f empty) (f t)) + (if f t then [ Atom "true" ] else [ Atom "false" ]) + rem + in + [] + |> bool "effects_without_cps" (fun t -> t.effects_without_cps) + |> set "primitives" (fun t -> t.primitives) + |> bool "force_link" (fun t -> t.force_link) + |> set "requires" (fun t -> StringSet.elements t.requires) + |> add "provides" false [ Atom (StringSet.choose t.provides) ] + +let from_sexp t = + let open Sexp.Util in + let opt_list l = l |> Option.map ~f:(List.map ~f:string) in + let list default l = Option.value ~default (opt_list l) in + let set default l = + Option.value ~default (Option.map ~f:StringSet.of_list (opt_list l)) + in + let bool default v = Option.value ~default (Option.map ~f:(single bool) v) in + { provides = t |> member "provides" |> mandatory (single string) |> StringSet.singleton + ; requires = t |> member "requires" |> set empty.requires + ; primitives = t |> member "primitives" |> list empty.primitives + ; force_link = t |> member "force_link" |> bool empty.force_link + ; effects_without_cps = + t |> member "effects_without_cps" |> bool empty.effects_without_cps + ; crcs = StringMap.empty + } diff --git a/compiler/lib/unit_info.mli b/compiler/lib/unit_info.mli index 1899b5657b..cd0895fa9d 100644 --- a/compiler/lib/unit_info.mli +++ b/compiler/lib/unit_info.mli @@ -41,3 +41,7 @@ val prefix : string val to_string : t -> string val parse : t -> string -> t option + +val to_sexp : t -> Sexp.t list + +val from_sexp : Sexp.t -> t