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

4
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -666,7 +666,9 @@ let () =
register "list?" (fun args ->
match args with [List _] | [ListRef _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "list?: 1 arg"));
register "dict?" (fun args ->
match args with [Dict _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
match args with [Dict _] -> Bool true | [AdtValue _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
register "adt?" (fun args ->
match args with [AdtValue _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "adt?: 1 arg"));
register "symbol?" (fun args ->
match args with [Symbol _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "symbol?: 1 arg"));
register "keyword?" (fun args ->

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
| _ -> ())

7
hosts/ocaml/lib/sx_runtime.ml
View File

@@ -209,6 +209,13 @@ let get_val container key =
| _ -> Nil)
| Dict d, String k -> dict_get d k
| Dict d, Keyword k -> dict_get d k
| AdtValue a, String k | AdtValue a, Keyword k ->
(match k with
| "_adt" -> Bool true
| "_type" -> String a.av_type
| "_ctor" -> String a.av_ctor
| "_fields" -> List (Array.to_list a.av_fields)
| _ -> Nil)
| (List l | ListRef { contents = l }), Number n ->
(try List.nth l (int_of_float n) with _ -> Nil)
| (List l | ListRef { contents = l }), Integer n ->

17
hosts/ocaml/lib/sx_types.ml
View File

@@ -82,6 +82,16 @@ and value =
| SxSet of (string, value) Hashtbl.t (** Mutable set keyed by inspect(value). *)
| SxRegexp of string * string * Re.re (** Regexp: source, flags, compiled. *)
| SxBytevector of bytes (** Mutable bytevector — R7RS bytevector type. *)
| AdtValue of adt_value (** Native algebraic data type instance — opaque sum type. *)
(** Algebraic data type instance — produced by [define-type] constructors.
[av_type] is the type name (e.g. "Maybe"), [av_ctor] is the constructor
name (e.g. "Just"), [av_fields] are the positional field values. *)
and adt_value = {
av_type : string;
av_ctor : string;
av_fields : value array;
}
(** String input port: source string + mutable cursor position. *)
and sx_port_kind =
@@ -520,6 +530,7 @@ let type_of = function
| SxSet _ -> "set"
| SxRegexp _ -> "regexp"
| SxBytevector _ -> "bytevector"
| AdtValue a -> a.av_type
let is_nil = function Nil -> true | _ -> false
let is_lambda = function Lambda _ -> true | _ -> false
@@ -885,3 +896,9 @@ let rec inspect = function
| SxSet ht -> Printf.sprintf "<set:%d>" (Hashtbl.length ht)
| SxRegexp (src, flags, _) -> Printf.sprintf "#/%s/%s" src flags
| SxBytevector b -> Printf.sprintf "#u8(%s)" (String.concat " " (List.init (Bytes.length b) (fun i -> string_of_int (Char.code (Bytes.get b i)))))
| AdtValue a ->
if Array.length a.av_fields = 0 then
Printf.sprintf "(%s)" a.av_ctor
else
let parts = Array.to_list (Array.map inspect a.av_fields) in
Printf.sprintf "(%s %s)" a.av_ctor (String.concat " " parts)