Verified Commit 40efec59 authored by james's avatar james
Browse files

fix(syntax): reject unexpected case fields

parent 92559a77

check.ml

+13 −0
Changes for check.ml: 13 added lines, 0 removed lines.
Original line number Diff line number Diff line
@@ -150,6 +150,19 @@ let graph () = 


let validation () =

  let case = read "buffering" in

  let open Sexp in

  let entries = List.tl (list (Syntax.encode case)) in

  let decode entries = ignore (Syntax.decode (List (Atom "case" :: entries))) in

  List.iter (fun extra ->

    rejects (fun () -> decode (extra :: entries)) "unexpected case field")

    [List [Atom "bounds"; i 8]; Atom "extra"; List []; List [List []]];

  List.iter (fun extra ->

    let entries = List.map (function

      | List [Atom "goal"; List (Atom "outcome" :: goal)] ->

          List [Atom "goal"; List (Atom "outcome" :: extra :: goal)]

      | field -> field) entries in

    rejects (fun () -> decode entries) "unexpected outcome field")

    [List [Atom "drain"; Atom "true"]; Atom "extra"; List []];

  List.iter (fun case -> rejects (fun () -> Syntax.validate case) "invalid case") [

    {case with bound=0}; {case with bound=65}; {case with names=[||]};

    {case with threads=[||]}; {case with candidates=[0, 9]};

syntax.ml

+18 −10
Changes for syntax.ml: 18 added lines, 10 removed lines.
Original line number Diff line number Diff line
@@ -79,23 +79,31 @@ let validate case = 


let singleton = function [value] -> value | _ -> invalid_arg "expected one field value"



let fields allowed values =

  List.iter (function

    | Sexp.List (Sexp.Atom name :: _) when List.mem name allowed -> ()

    | Sexp.List (Sexp.Atom name :: _) -> invalid_arg ("unknown field " ^ name)

    | _ -> invalid_arg "malformed field") values



let decode value =

  let open Sexp in

  let fields = match value with

  let entries = match value with

    | List (Atom "case" :: fields) -> fields

    | _ -> invalid_arg "expected case"

  in

  let get key = singleton (field key fields) in

  let goal = match field "goal" fields with

  fields ["name"; "names"; "bound"; "threads"; "candidates"; "goal"] entries;

  let get key = singleton (field key entries) in

  let goal = match field "goal" entries with

    | [Atom "overlap"] -> Overlap

    | [List (Atom "outcome" :: fields)] ->

    | [List (Atom "outcome" :: entries)] ->

        fields ["registers"; "memory"; "drained"] entries;

        let registers = List.map (fun value -> match list value with

          | [t; r; v] -> integer t, integer r, word v

          | _ -> invalid_arg "invalid register goal") (field "registers" fields) in

          | _ -> invalid_arg "invalid register goal") (field "registers" entries) in

        let memory = List.map (fun value -> match list value with

          | [a; v] -> integer a, word v

          | _ -> invalid_arg "invalid memory goal") (field "memory" fields) in

        let drained = match field "drained" fields with

          | _ -> invalid_arg "invalid memory goal") (field "memory" entries) in

        let drained = match field "drained" entries with

          | [Atom "true"] -> true | [Atom "false"] -> false

          | _ -> invalid_arg "invalid drain flag" in

        Outcome {registers; memory; drained}
@@ -103,11 +111,11 @@ let decode value = 
  in

  let case = {

    name = atom (get "name");

    names = Array.of_list (List.map atom (field "names" fields));

    names = Array.of_list (List.map atom (field "names" entries));

    bound = integer (get "bound");

    threads = Array.of_list (List.map (fun thread ->

      Array.of_list (List.map decode_instruction (list thread))) (field "threads" fields));

    candidates = List.map location (field "candidates" fields);

      Array.of_list (List.map decode_instruction (list thread))) (field "threads" entries));

    candidates = List.map location (field "candidates" entries);

    goal;

  } in

  validate case;