fix(syntax): reject unexpected case fields

commit: 40efec59037c8cfdff06a3d121284b6212866a65 browse tree
parent: 92559a776820e2717d0f453429eec81291f521a9
author: james <j@cpl0.zip>
signature: Verified ~james signed with a key registered by ~james
date: 2026-10-28 20:08 UTC

2 files changed, +31 −10

check.ml modified +13 −0
syntax.ml modified +18 −10

check.ml modified

@@ -150,6 +150,19 @@ let graph () =
150	150
151	151	let validation () =
152	152	let case = read "buffering" in
	153	+ let open Sexp in
	154	+ let entries = List.tl (list (Syntax.encode case)) in
	155	+ let decode entries = ignore (Syntax.decode (List (Atom "case" :: entries))) in
	156	+ List.iter (fun extra ->
	157	+ rejects (fun () -> decode (extra :: entries)) "unexpected case field")
	158	+ [List [Atom "bounds"; i 8]; Atom "extra"; List []; List [List []]];
	159	+ List.iter (fun extra ->
	160	+ let entries = List.map (function
	161	+ \| List [Atom "goal"; List (Atom "outcome" :: goal)] ->
	162	+ List [Atom "goal"; List (Atom "outcome" :: extra :: goal)]
	163	+ \| field -> field) entries in
	164	+ rejects (fun () -> decode entries) "unexpected outcome field")
	165	+ [List [Atom "drain"; Atom "true"]; Atom "extra"; List []];
153	166	List.iter (fun case -> rejects (fun () -> Syntax.validate case) "invalid case") [
154	167	{case with bound=0}; {case with bound=65}; {case with names=[\|\|]};
155	168	{case with threads=[\|\|]}; {case with candidates=[0, 9]};

syntax.ml modified

@@ -79,23 +79,31 @@ let validate case =
79	79
80	80	let singleton = function [value] -> value \| _ -> invalid_arg "expected one field value"
81	81
	82	+let fields allowed values =
	83	+ List.iter (function
	84	+ \| Sexp.List (Sexp.Atom name :: _) when List.mem name allowed -> ()
	85	+ \| Sexp.List (Sexp.Atom name :: _) -> invalid_arg ("unknown field " ^ name)
	86	+ \| _ -> invalid_arg "malformed field") values
	87	+
82	88	let decode value =
83	89	let open Sexp in
84		- let fields = match value with
	90	+ let entries = match value with
85	91	\| List (Atom "case" :: fields) -> fields
86	92	\| _ -> invalid_arg "expected case"
87	93	in
88		- let get key = singleton (field key fields) in
89		- let goal = match field "goal" fields with
	94	+ fields ["name"; "names"; "bound"; "threads"; "candidates"; "goal"] entries;
	95	+ let get key = singleton (field key entries) in
	96	+ let goal = match field "goal" entries with
90	97	\| [Atom "overlap"] -> Overlap
91		- \| [List (Atom "outcome" :: fields)] ->
	98	+ \| [List (Atom "outcome" :: entries)] ->
	99	+ fields ["registers"; "memory"; "drained"] entries;
92	100	let registers = List.map (fun value -> match list value with
93	101	\| [t; r; v] -> integer t, integer r, word v
94		- \| _ -> invalid_arg "invalid register goal") (field "registers" fields) in
	102	+ \| _ -> invalid_arg "invalid register goal") (field "registers" entries) in
95	103	let memory = List.map (fun value -> match list value with
96	104	\| [a; v] -> integer a, word v
97		- \| _ -> invalid_arg "invalid memory goal") (field "memory" fields) in
98		- let drained = match field "drained" fields with
	105	+ \| _ -> invalid_arg "invalid memory goal") (field "memory" entries) in
	106	+ let drained = match field "drained" entries with
99	107	\| [Atom "true"] -> true \| [Atom "false"] -> false
100	108	\| _ -> invalid_arg "invalid drain flag" in
101	109	Outcome {registers; memory; drained}

@@ -103,11 +111,11 @@ let decode value =
103	111	in
104	112	let case = {
105	113	name = atom (get "name");
106		- names = Array.of_list (List.map atom (field "names" fields));
	114	+ names = Array.of_list (List.map atom (field "names" entries));
107	115	bound = integer (get "bound");
108	116	threads = Array.of_list (List.map (fun thread ->
109		- Array.of_list (List.map decode_instruction (list thread))) (field "threads" fields));
110		- candidates = List.map location (field "candidates" fields);
	117	+ Array.of_list (List.map decode_instruction (list thread))) (field "threads" entries));
	118	+ candidates = List.map location (field "candidates" entries);
111	119	goal;
112	120	} in
113	121	validate case;

~james/reorder

fix(syntax): reject unexpected case fields

check.ml modified

syntax.ml modified