coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

sx: step 5 — OCaml AdtValue + define-type + match

Browse Source 
Native algebraic data type representation in the OCaml SX evaluator.
Replaces the dict-based shim that simulated ADT values via tagged dicts.

- sx_types.ml: add AdtValue variant + adt_value record (av_type, av_ctor,
  av_fields). type_of returns the type name (e.g. "Maybe"); inspect renders
  as a constructor call (e.g. "(Just 42)" or "(Nothing)").
- sx_runtime.ml: get_val handles AdtValue with :_adt/:_type/:_ctor/:_fields
  keys for back-compat with spec-level match-pattern code.
- sx_primitives.ml: dict? returns true for AdtValue (so existing match
  dispatch keeps working); new adt? predicate distinguishes ADT values.
- sx_ref.ml: sf_define_type now constructs AdtValue instead of Dict.
  Predicates (Name?, Ctor?) and accessors (Ctor-field) match on AdtValue
  with proper type/ctor name and field index checks.
- spec/tests/test-adt.sx: 3 new tests covering type-of, adt?, and inspect.

Tests: 4532 passed (was 4529 + 3 new), 1339 failed (unchanged baseline).
All 43 ADT tests pass on the native representation.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-06 22:54:33 +00:00
parent b19f2017d0
commit 1f49242ae3
6 changed files with 152 additions and 53 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
hosts/ocaml/lib/sx_ref.ml
View File

@@ -1054,8 +1054,7 @@ let sf_define_type args env_val =
(match pargs with
| [v] ->
(match v with
| Dict d -> Bool (Hashtbl.mem d "_adt" &&
(match Hashtbl.find_opt d "_type" with Some (String t) -> t = type_name | _ -> false))
| AdtValue a -> Bool (a.av_type = type_name)
| _ -> Bool false)
| _ -> Bool false)));
List.iter (fun spec ->
@@ -1069,21 +1068,18 @@ let sf_define_type args env_val =
if List.length ctor_args <> arity then
raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d"
cn arity (List.length ctor_args)))
else begin
let d = Hashtbl.create 4 in
Hashtbl.replace d "_adt" (Bool true);
Hashtbl.replace d "_type" (String type_name);
Hashtbl.replace d "_ctor" (String cn);
Hashtbl.replace d "_fields" (List ctor_args);
Dict d
end));
else
AdtValue {
av_type = type_name;
av_ctor = cn;
av_fields = Array.of_list ctor_args;
}));
env_bind_v (cn ^ "?")
(NativeFn (cn ^ "?", fun pargs ->
(match pargs with
| [v] ->
(match v with
| Dict d -> Bool (Hashtbl.mem d "_adt" &&
(match Hashtbl.find_opt d "_ctor" with Some (String c) -> c = cn | _ -> false))
| AdtValue a -> Bool (a.av_ctor = cn)
| _ -> Bool false)
| _ -> Bool false)));
List.iteri (fun idx fname ->
@@ -1092,13 +1088,10 @@ let sf_define_type args env_val =
(match pargs with
| [v] ->
(match v with
| Dict d ->
(match Hashtbl.find_opt d "_fields" with
| Some (List fs) ->
if idx < List.length fs then List.nth fs idx
else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds"))
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT")))
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not a dict")))
| AdtValue a ->
if idx < Array.length a.av_fields then a.av_fields.(idx)
else raise (Eval_error (cn ^ "-" ^ fname ^ ": index out of bounds"))
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": not an ADT")))
| _ -> raise (Eval_error (cn ^ "-" ^ fname ^ ": expected 1 arg")))))
) field_names
| _ -> ())