(** Core types for the SX language.

    The [value] sum type represents every possible SX runtime value.
    OCaml's algebraic types make the CEK machine's frame dispatch a
    pattern match — exactly what the spec describes. *)

(** {1 Symbol interning} *)

(** Map symbol names to small integers for O(1) env lookups.
    The intern table is populated once per unique symbol name;
    all subsequent env operations use the integer key. *)

let sym_to_id : (string, int) Hashtbl.t = Hashtbl.create 512
let id_to_sym : (int, string) Hashtbl.t = Hashtbl.create 512
let sym_next  = ref 0

let intern s =
  match Hashtbl.find_opt sym_to_id s with
  | Some id -> id
  | None ->
    let id = !sym_next in
    incr sym_next;
    Hashtbl.replace sym_to_id s id;
    Hashtbl.replace id_to_sym id s;
    id

let unintern id =
  match Hashtbl.find_opt id_to_sym id with
  | Some s -> s
  | None -> "<sym:" ^ string_of_int id ^ ">"


(** {1 Environment} *)

(** Lexical scope chain.  Each frame holds a mutable binding table
    keyed by interned symbol IDs for fast lookup. *)
type env = {
  bindings : (int, value) Hashtbl.t;
  parent   : env option;
}

(** {1 Values} *)

and value =
  | Nil
  | Bool    of bool
  | Integer of int    (** Exact integer — distinct from inexact float. *)
  | Number  of float  (** Inexact float. *)
  | String  of string
  | Symbol of string
  | Keyword of string
  | List   of value list
  | Dict   of dict
  | Lambda of lambda
  | Component of component
  | Island of island
  | Macro  of macro
  | Thunk  of value * env
  | Continuation of (value -> value) * dict option
  | CallccContinuation of value list * int  (** Undelimited continuation — captured kont frames + winders depth at capture *)
  | NativeFn of string * (value list -> value)
  | Signal of signal
  | RawHTML of string
  | Spread of (string * value) list
  | SxExpr of string  (** Opaque SX wire-format string — aser output. *)
  | Env of env  (** First-class environment — used by CEK machine state dicts. *)
  | ListRef of value list ref  (** Mutable list — JS-style array for append! *)
  | CekState of cek_state  (** Optimized CEK machine state — avoids Dict allocation. *)
  | CekFrame of cek_frame  (** Optimized CEK continuation frame. *)
  | VmClosure of vm_closure  (** VM-compiled closure — callable within the VM without allocating a new VM. *)
  | VmFrame of vm_frame  (** VM call frame — one per function invocation. *)
  | VmMachine of vm_machine  (** VM state — stack, frames, globals. *)
  | Record of record  (** R7RS record — opaque, generative, field-indexed. *)
  | Parameter of parameter  (** R7RS parameter — dynamic binding via kont-stack provide frames. *)
  | Vector of value array  (** R7RS vector — mutable fixed-size array. *)
  | StringBuffer of Buffer.t  (** Mutable string buffer — O(1) amortized append. *)
  | HashTable of (value, value) Hashtbl.t  (** Mutable hash table with arbitrary keys. *)
  | Char of int  (** Unicode codepoint — R7RS char type. *)
  | Eof            (** EOF sentinel — returned by read-char etc. at end of input. *)
  | Port of sx_port  (** String port — input (string cursor) or output (buffer). *)
  | Rational of int * int  (** Exact rational: numerator, denominator (reduced, denom>0). *)
  | 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 =
  | PortInput of string * int ref
  | PortOutput of Buffer.t

and sx_port = {
  mutable sp_closed : bool;
  sp_kind : sx_port_kind;
}

(** CEK machine state — record instead of Dict for performance.
    5 fields × 55K steps/sec = 275K Hashtbl allocations/sec eliminated. *)
and cek_state = {
  cs_control : value;
  cs_env     : value;
  cs_kont    : value;
  cs_phase   : string;
  cs_value   : value;
}

(** CEK continuation frame — tagged record covering all 29 frame types.
    Fields are named generically; not all are used by every frame type.
    Eliminates ~100K Hashtbl allocations per page render. *)
and cek_frame = {
  cf_type      : string;        (* frame type tag: "if", "let", "call", etc. *)
  cf_env       : value;         (* environment — every frame has this *)
  cf_name      : value;         (* let/define/set/scope: binding name *)
  cf_body      : value;         (* when/let: body expr *)
  mutable cf_remaining : value;  (* begin/cond/map/etc: remaining exprs *)
  cf_f         : value;         (* call/map/filter/etc: function *)
  cf_args      : value;         (* call: raw args; arg: evaled args *)
  mutable cf_results   : value; (* map/filter/dict: accumulated results; provide: subscribers *)
  mutable cf_extra : value;     (* extra field: scheme, indexed, value, phase, etc. *)
  mutable cf_extra2    : value; (* second extra: emitted, etc. *)
}

(** Mutable string-keyed table (SX dicts support [dict-set!]). *)
and dict = (string, value) Hashtbl.t

and lambda = {
  l_params  : string list;
  l_body    : value;
  l_closure : env;
  mutable l_name : string option;
  mutable l_compiled : vm_closure option;  (** Lazy JIT cache *)
  mutable l_call_count : int;              (** Tiered-compilation counter — JIT after threshold calls *)
  l_uid : int;                             (** Unique identity for LRU cache tracking *)
}

and component = {
  c_name         : string;
  c_params       : string list;
  c_has_children : bool;
  c_body         : value;
  c_closure      : env;
  c_affinity     : string;  (** "auto" | "client" | "server" *)
  mutable c_file : string option;  (** Source file path *)
  mutable c_compiled : vm_closure option;  (** Lazy JIT cache *)
}

and island = {
  i_name         : string;
  i_params       : string list;
  i_has_children : bool;
  i_body         : value;
  i_closure      : env;
  mutable i_file : string option;  (** Source file path *)
  mutable i_compiled : vm_closure option;  (** Lazy JIT cache *)
}

and macro = {
  m_params     : string list;
  m_rest_param : string option;
  m_body       : value;
  m_closure    : env;
  m_name       : string option;
}

and signal = {
  mutable s_value       : value;
  mutable s_subscribers : (unit -> unit) list;
  mutable s_deps        : signal list;
}

(** R7RS record type descriptor — one per [define-record-type] call.
    Stored in [rtd_table]; closures capture only the integer uid. *)
and record_type = {
  rt_name     : string;       (** e.g., "point" *)
  rt_uid      : int;          (** unique identity — generative *)
  rt_fields   : string array; (** field names in declaration order *)
  rt_ctor_map : int array;    (** ctor_map[i] = field index for ctor param i *)
}

(** R7RS record instance — opaque, accessed only through generated functions. *)
and record = {
  r_type   : record_type;
  r_fields : value array;     (** mutable via Array.set for record-set! *)
}

(** R7RS parameter — dynamic binding via provide frames on the kont stack.
    Calling [(param)] searches kont for the nearest provide frame keyed
    by [pm_uid]; if not found returns [pm_default]. *)
and parameter = {
  pm_uid       : string;      (** unique ID — used as provide frame key *)
  pm_default   : value;       (** initial/default value *)
  pm_converter : value option; (** optional converter function *)
}

(** {1 Bytecode VM types}

    Defined here (not in sx_vm.ml) because [vm_code.constants] references
    [value] and [lambda.l_compiled] references [vm_closure] — mutual
    recursion requires all types in one [and] chain. *)

(** Compiled function body — bytecode + constant pool. *)
and vm_code = {
  vc_arity     : int;
  vc_rest_arity : int;  (** -1 = no &rest; >= 0 = number of positional params before &rest *)
  vc_locals    : int;
  vc_bytecode  : int array;
  vc_constants : value array;
  mutable vc_bytecode_list  : value list option;  (** Lazy cache for transpiled VM *)
  mutable vc_constants_list : value list option;  (** Lazy cache for transpiled VM *)
}

(** Upvalue cell — shared mutable reference to a captured variable. *)
and vm_upvalue_cell = {
  mutable uv_value : value;
}

(** Closure — compiled code + captured upvalues + live env reference. *)
and vm_closure = {
  vm_code     : vm_code;
  vm_upvalues : vm_upvalue_cell array;
  vm_name     : string option;
  vm_env_ref  : (string, value) Hashtbl.t;
  vm_closure_env : env option;  (** Original closure env for inner functions *)
}

(** VM call frame — one per function invocation.
    Defined here (not in sx_vm.ml) so it can be a [value] variant. *)
and vm_frame = {
  vf_closure    : vm_closure;
  mutable vf_ip : int;
  vf_base       : int;
  vf_local_cells : (int, vm_upvalue_cell) Hashtbl.t;
}

(** VM state — stack machine with frame list.
    Defined here for the same mutual-recursion reason. *)
and vm_machine = {
  mutable vm_stack   : value array;
  mutable vm_sp      : int;
  mutable vm_frames  : vm_frame list;
  vm_globals         : (string, value) Hashtbl.t;
  mutable vm_pending_cek : value option;
}


(** {1 Forward ref for calling VM closures from outside the VM} *)

let _vm_call_closure_ref : (vm_closure -> value list -> value) ref =
  ref (fun _ _ -> raise (Failure "VM call_closure not initialized"))

(** Forward ref for calling CEK evaluator from primitives (avoids dependency cycle). *)
let _cek_call_ref : (value -> value -> value) ref =
  ref (fun _ _ -> raise (Failure "CEK call not initialized"))

(** Forward ref: evaluate a Lambda via CEK (supports perform/suspension).
    Set by sx_vm.ml to break the sx_runtime → sx_ref dependency cycle. *)
let _cek_eval_lambda_ref : (value -> value list -> value) ref =
  ref (fun _ _ -> raise (Failure "CEK eval lambda not initialized"))


(** {1 Errors} *)

exception Eval_error of string
exception Parse_error of string

(** Raised when a VmClosure hits OP_PERFORM inside a CEK evaluation.
    The CEK step loop catches this and creates a proper io-suspended state
    with the continuation preserved for resume. Defined here (not in sx_vm)
    to avoid a dependency cycle between sx_runtime and sx_vm. *)
exception CekPerformRequest of value

(** Hook: resolve IO suspension inline in cek_run.
    When set, cek_run calls this instead of raising "IO suspension in non-IO context".
    The function receives the suspended state and returns the resolved value.
    Used by the HTTP server to handle perform (text-measure) during aser. *)
let _cek_io_resolver : (value -> value -> value) option ref = ref None

(** Hook: handle CEK IO suspension in eval_expr (cek_run_iterative).
    When set, called with the suspended CEK state instead of raising
    "IO suspension in non-IO context". Used by the browser WASM kernel
    to convert CEK suspensions to VmSuspended for _driveAsync handling. *)
let _cek_io_suspend_hook : (value -> value) option ref = ref None

(** Default VM globals for stub VMs created during IO suspension.
    Set by sx_browser.ml to _vm_globals so CEK resume can access platform functions. *)
let _default_vm_globals : (string, value) Hashtbl.t ref = ref (Hashtbl.create 0)

(** Hook: convert VM suspension exceptions to CekPerformRequest.
    Set by sx_vm after it defines VmSuspended. Called by sx_runtime.sx_apply_cek. *)
let _convert_vm_suspension : (exn -> unit) ref = ref (fun _ -> ())

(** Hook: convert VM suspension to a __vm_suspended marker dict.
    Returns Some(dict) for VmSuspended, None otherwise.
    The dict has keys: __vm_suspended, request, resume.
    Used by sx_apply_cek so continue_with_call can build a proper
    suspended CEK state with vm-resume-frame on the kont. *)
let _vm_suspension_to_dict : (exn -> value option) ref = ref (fun _ -> None)


(** {1 Record type descriptor table} *)

let rtd_table : (int, record_type) Hashtbl.t = Hashtbl.create 16
let rtd_counter = ref 0

(** {1 Parameter UID counter} *)

let param_counter = ref 0


(** {1 Environment operations} *)

let make_env () =
  { bindings = Hashtbl.create 16; parent = None }

let env_extend parent =
  { bindings = Hashtbl.create 16; parent = Some parent }

(* Optional hook: called after every env_bind with (env, name, value).
   Used by browser kernel to sync VM globals table. *)
let _env_bind_hook : (env -> string -> value -> unit) option ref = ref None

(* Optional hook: called after VM GLOBAL_SET writes to vm.globals.
   Used by browser kernel to sync mutations back to global_env. *)
let _vm_global_set_hook : (string -> value -> unit) option ref = ref None

(* Optional hook: called by cek_run on import suspension.
   If set, the hook loads the library and returns true; cek_run then resumes. *)
let _import_hook : (value -> bool) option ref = ref None

(* Optional hook: called by vm_global_get when a symbol isn't found.
   Receives the symbol name. If the hook can resolve it (e.g. by loading a
   library that exports it), it returns Some value. Otherwise None.
   This enables transparent lazy module loading — just use a symbol and
   the VM loads whatever module provides it. *)
let _symbol_resolve_hook : (string -> value option) option ref = ref None

let env_bind env name v =
  Hashtbl.replace env.bindings (intern name) v;
  (match !_env_bind_hook with Some f -> f env name v | None -> ());
  Nil

(* Internal: scope-chain lookup with pre-interned ID *)
let rec env_has_id env id =
  Hashtbl.mem env.bindings id ||
  match env.parent with Some p -> env_has_id p id | None -> false

let env_has env name = env_has_id env (intern name)

let rec env_get_id env id name =
  match Hashtbl.find_opt env.bindings id with
  | Some v -> v
  | None ->
    match env.parent with
    | Some p -> env_get_id p id name
    | None ->
      (* Symbol not in any scope — try the resolve hook (transparent lazy loading).
         The hook loads the module that exports this symbol, making it available. *)
      match !_symbol_resolve_hook with
      | Some hook ->
        (match hook name with
         | Some v ->
           (* Cache in the root env so subsequent lookups are instant *)
           Hashtbl.replace env.bindings id v; v
         | None -> raise (Eval_error ("Undefined symbol: " ^ name)))
      | None -> raise (Eval_error ("Undefined symbol: " ^ name))

let env_get env name = env_get_id env (intern name) name

let rec env_set_id env id v =
  if Hashtbl.mem env.bindings id then begin
    Hashtbl.replace env.bindings id v;
    (match !_env_bind_hook with Some f -> f env (unintern id) v | None -> ());
    Nil
  end else
    match env.parent with
    | Some p -> env_set_id p id v
    | None -> Hashtbl.replace env.bindings id v; Nil

let env_set env name v = env_set_id env (intern name) v

let env_merge base overlay =
  if base == overlay then
    { bindings = Hashtbl.create 16; parent = Some base }
  else begin
    let rec is_descendant e depth =
      if depth > 100 then false
      else if e == base then true
      else match e.parent with Some p -> is_descendant p (depth + 1) | None -> false
    in
    if is_descendant overlay 0 then
      { bindings = Hashtbl.create 16; parent = Some base }
    else begin
      let e = { bindings = Hashtbl.create 16; parent = Some base } in
      Hashtbl.iter (fun id v ->
        if not (env_has_id base id) then Hashtbl.replace e.bindings id v
      ) overlay.bindings;
      e
    end
  end


(** {1 Value extraction helpers} *)

(** Format a float safely — defuse [int_of_float] overflow on huge
    integer-valued floats, keep [%g] for fractions (unchanged). *)
let format_number n =
  if Float.is_nan n then "nan"
  else if n = Float.infinity then "inf"
  else if n = Float.neg_infinity then "-inf"
  else if Float.is_integer n && Float.abs n < 1e16 then
    string_of_int (int_of_float n)
  else if Float.is_integer n then
    Printf.sprintf "%.17g" n
  else Printf.sprintf "%g" n

let value_to_string = function
  | String s -> s | Symbol s -> s | Keyword k -> k
  | Integer n -> string_of_int n
  | Number n -> format_number n
  | Bool true -> "true" | Bool false -> "false"
  | Nil -> "" | _ -> "<value>"

let value_to_string_list = function
  | List items | ListRef { contents = items } -> List.map value_to_string items
  | _ -> []

let value_to_bool = function
  | Bool b -> b | Nil -> false | _ -> true

let value_to_string_opt = function
  | String s -> Some s | Symbol s -> Some s | Nil -> None | _ -> None


(** {1 Constructors — accept [value] args from transpiled code} *)

let unwrap_env_val = function
  | Env e -> e
  | _ -> raise (Eval_error "make_lambda: expected env for closure")

(* Lambda UID — minted on construction, used as LRU cache key (Phase 2). *)
let lambda_uid_counter = ref 0
let next_lambda_uid () = incr lambda_uid_counter; !lambda_uid_counter

let make_lambda params body closure =
  let ps = match params with
    | List items -> List.map value_to_string items
    | _ -> value_to_string_list params
  in
  Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None; l_call_count = 0; l_uid = next_lambda_uid () }

(** {1 JIT cache control}

    Tiered compilation: only JIT a lambda after it's been called [jit_threshold]
    times. This filters out one-shot lambdas (test harness, dynamic eval, REPLs)
    so they never enter the JIT cache. Counters are exposed to SX as [(jit-stats)].

    These live here (in sx_types) rather than sx_vm so [sx_primitives] can read
    them without creating a sx_primitives → sx_vm dependency cycle. *)
let jit_threshold = ref 4
let jit_compiled_count = ref 0
let jit_skipped_count = ref 0
let jit_threshold_skipped_count = ref 0

(** {2 JIT cache LRU eviction — Phase 2}

    Once a lambda crosses the threshold, its [l_compiled] slot is filled.
    To bound memory under unbounded compilation pressure, track all live
    compiled lambdas in FIFO order, and evict from the head when the count
    exceeds [jit_budget].

    [lambda_uid_counter] mints unique identities on lambda creation; the
    LRU queue holds these IDs paired with a back-reference to the lambda
    so we can clear its [l_compiled] slot on eviction.

    Budget of 0 = no cache (disable JIT entirely).
    Budget of [max_int] = unbounded (legacy behaviour). Default 5000 is
    a generous ceiling for any realistic page; the test harness compiles
    ~3000 distinct one-shot lambdas in a full run but tiered compilation
    (Phase 1) means most never enter the cache, so steady-state count
    stays small.

    [lambda_uid_counter] and [next_lambda_uid] are defined above
    [make_lambda] (which uses them on construction). *)
let jit_budget = ref 5000
let jit_evicted_count = ref 0

(** Live compiled lambdas in FIFO order — front is oldest, back is newest.
    Each entry is (uid, lambda); on eviction we clear lambda.l_compiled and
    drop from the queue. Using a mutable Queue rather than a hand-rolled
    linked list because eviction is amortised O(1) at the head and inserts
    are O(1) at the tail. *)
let jit_cache_queue : (int * value) Queue.t = Queue.create ()
let jit_cache_size () = Queue.length jit_cache_queue

let make_component name params has_children body closure affinity =
  let n = value_to_string name in
  let ps = value_to_string_list params in
  let hc = value_to_bool has_children in
  let aff = match affinity with String s -> s | _ -> "auto" in
  Component {
    c_name = n; c_params = ps; c_has_children = hc;
    c_body = body; c_closure = unwrap_env_val closure; c_affinity = aff;
    c_file = None; c_compiled = None;
  }

let make_island name params has_children body closure =
  let n = value_to_string name in
  let ps = value_to_string_list params in
  let hc = value_to_bool has_children in
  Island {
    i_name = n; i_params = ps; i_has_children = hc;
    i_body = body; i_closure = unwrap_env_val closure;
    i_file = None; i_compiled = None;
  }

let make_macro params rest_param body closure name =
  let ps = value_to_string_list params in
  let rp = value_to_string_opt rest_param in
  let n = value_to_string_opt name in
  Macro {
    m_params = ps; m_rest_param = rp;
    m_body = body; m_closure = unwrap_env_val closure; m_name = n;
  }

let make_thunk expr env = Thunk (expr, unwrap_env_val env)

let make_symbol name = Symbol (value_to_string name)
let make_keyword name = Keyword (value_to_string name)


(** {1 Type inspection} *)

let type_of = function
  | Nil            -> "nil"
  | Bool _         -> "boolean"
  | Integer _      -> "number"
  | Number _       -> "number"
  | String _       -> "string"
  | Symbol _       -> "symbol"
  | Keyword _      -> "keyword"
  | List _ | ListRef _ -> "list"
  | Dict _         -> "dict"
  | Lambda _       -> "lambda"
  | Component _    -> "component"
  | Island _       -> "island"
  | Macro _        -> "macro"
  | Thunk _        -> "thunk"
  | Continuation (_, _) -> "continuation"
  | CallccContinuation (_, _) -> "continuation"
  | NativeFn _     -> "function"
  | Signal _       -> "signal"
  | RawHTML _      -> "raw-html"
  | Spread _       -> "spread"
  | SxExpr _       -> "sx-expr"
  | Env _          -> "env"
  | CekState _     -> "dict"  (* CEK state behaves as a dict for type checks *)
  | CekFrame _     -> "dict"
  | VmClosure _    -> "function"
  | VmFrame _      -> "vm-frame"
  | VmMachine _    -> "vm-machine"
  | Record r       -> r.r_type.rt_name
  | Parameter _    -> "parameter"
  | Vector _       -> "vector"
  | StringBuffer _ -> "string-buffer"
  | HashTable _    -> "hash-table"
  | Char _         -> "char"
  | Eof            -> "eof-object"
  | Port { sp_kind = PortInput _; _ }  -> "input-port"
  | Port { sp_kind = PortOutput _; _ } -> "output-port"
  | Rational _  -> "rational"
  | 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
let is_component = function Component _ -> true | _ -> false
let is_island = function Island _ -> true | _ -> false
let is_macro = function Macro _ -> true | _ -> false
let is_thunk = function Thunk _ -> true | _ -> false
let is_signal = function
  | Signal _ -> true
  | Dict d -> Hashtbl.mem d "__signal"
  | _ -> false

let is_record = function Record _ -> true | _ -> false

let is_callable = function
  | Lambda _ | NativeFn _ | Continuation (_, _) | CallccContinuation (_, _) | VmClosure _ -> true
  | _ -> false


(** {1 Truthiness} *)

(** SX truthiness: everything is truthy except [Nil] and [Bool false]. *)
let sx_truthy = function
  | Nil | Bool false -> false
  | _ -> true


(** {1 Accessors} *)

let symbol_name = function
  | Symbol s -> String s
  | v -> raise (Eval_error ("Expected symbol, got " ^ type_of v))

let keyword_name = function
  | Keyword k -> String k
  | v -> raise (Eval_error ("Expected keyword, got " ^ type_of v))

let lambda_params = function
  | Lambda l -> List (List.map (fun s -> String s) l.l_params)
  | v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))

let lambda_body = function
  | Lambda l -> l.l_body
  | v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))

let lambda_closure = function
  | Lambda l -> Env l.l_closure
  | v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))

let lambda_name = function
  | Lambda l -> (match l.l_name with Some n -> String n | None -> Nil)
  | v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))

let set_lambda_name l n = match l with
  | Lambda l -> l.l_name <- Some n; Nil
  | _ -> raise (Eval_error "set-lambda-name!: not a lambda")

let component_name = function
  | Component c -> String c.c_name
  | Island i -> String i.i_name
  | v -> raise (Eval_error ("Expected component, got " ^ type_of v))

let component_file = function
  | Component c -> (match c.c_file with Some f -> String f | None -> Nil)
  | Island i -> (match i.i_file with Some f -> String f | None -> Nil)
  | _ -> Nil

let component_set_file v f =
  (match v, f with
  | Component c, String s -> c.c_file <- Some s
  | Island i, String s -> i.i_file <- Some s
  | _ -> ()); Nil

let component_set_file_b = component_set_file

let component_params = function
  | Component c -> List (List.map (fun s -> String s) c.c_params)
  | Island i -> List (List.map (fun s -> String s) i.i_params)
  | v -> raise (Eval_error ("Expected component, got " ^ type_of v))

let component_body = function
  | Component c -> c.c_body
  | Island i -> i.i_body
  | v -> raise (Eval_error ("Expected component, got " ^ type_of v))

let component_closure = function
  | Component c -> Env c.c_closure
  | Island i -> Env i.i_closure
  | v -> raise (Eval_error ("Expected component, got " ^ type_of v))

let component_has_children = function
  | Component c -> Bool c.c_has_children
  | Island i -> Bool i.i_has_children
  | v -> raise (Eval_error ("Expected component, got " ^ type_of v))

let component_affinity = function
  | Component c -> String c.c_affinity
  | Island _ -> String "client"
  | _ -> String "auto"

let macro_params = function
  | Macro m -> List (List.map (fun s -> String s) m.m_params)
  | v -> raise (Eval_error ("Expected macro, got " ^ type_of v))

let macro_rest_param = function
  | Macro m -> (match m.m_rest_param with Some s -> String s | None -> Nil)
  | v -> raise (Eval_error ("Expected macro, got " ^ type_of v))

let macro_body = function
  | Macro m -> m.m_body
  | v -> raise (Eval_error ("Expected macro, got " ^ type_of v))

let macro_closure = function
  | Macro m -> Env m.m_closure
  | v -> raise (Eval_error ("Expected macro, got " ^ type_of v))

let thunk_expr = function
  | Thunk (e, _) -> e
  | v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))

let thunk_env = function
  | Thunk (_, e) -> Env e
  | v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))


(** {1 Record operations} *)

let val_to_int = function
  | Integer n -> n
  | Number n -> int_of_float n
  | v -> raise (Eval_error ("Expected number, got " ^ type_of v))

(** [make_rtd name fields ctor_params] — create a record type descriptor.
    Called as [make-rtd] from transpiled evaluator. Takes 3 separate args. *)
let make_rtd name fields ctor_params =
  let uid = !rtd_counter in
  incr rtd_counter;
  let field_names = List.map value_to_string (match fields with List l -> l | _ -> []) in
  let ctor_names = List.map value_to_string (match ctor_params with List l -> l | _ -> []) in
  let field_arr = Array.of_list field_names in
  let ctor_map = Array.of_list (List.map (fun cp ->
    let rec find j = function
      | [] -> raise (Eval_error (Printf.sprintf "make-rtd: ctor param %s not in fields" cp))
      | f :: _ when f = cp -> j
      | _ :: rest -> find (j + 1) rest
    in find 0 field_names
  ) ctor_names) in
  let rt = { rt_name = value_to_string name; rt_uid = uid; rt_fields = field_arr; rt_ctor_map = ctor_map } in
  Hashtbl.add rtd_table uid rt;
  Number (float_of_int uid)

(** [make_record uid_val args_list] — create a record from uid + args list.
    2-arg direct call: (make-record rtd-uid ctor-args-list). *)
let make_record uid_val args_list =
  let uid = val_to_int uid_val in
  let ctor_args = match args_list with List l -> l | _ -> [] in
  match Hashtbl.find_opt rtd_table uid with
  | None -> raise (Eval_error "make-record: unknown rtd")
  | Some rt ->
    let n_ctor = Array.length rt.rt_ctor_map in
    let n_args = List.length ctor_args in
    if n_args <> n_ctor then
      raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d"
        rt.rt_name n_ctor n_args));
    let fields = Array.make (Array.length rt.rt_fields) Nil in
    List.iteri (fun i arg ->
      fields.(rt.rt_ctor_map.(i)) <- arg
    ) ctor_args;
    Record { r_type = rt; r_fields = fields }

(** [record_ref v idx] — access field by index. 2-arg direct call. *)
let record_ref v idx =
  match v with
  | Record r ->
    let i = val_to_int idx in
    if i < 0 || i >= Array.length r.r_fields then
      raise (Eval_error (Printf.sprintf "record-ref: index %d out of bounds for %s" i r.r_type.rt_name));
    r.r_fields.(i)
  | _ -> raise (Eval_error ("record-ref: not a record, got " ^ type_of v))

(** [record_set_b v idx new_val] — mutate field by index. 3-arg direct call.
    Named record_set_b because transpiler mangles record-set! to record_set_b. *)
let record_set_b v idx new_val =
  match v with
  | Record r ->
    let i = val_to_int idx in
    if i < 0 || i >= Array.length r.r_fields then
      raise (Eval_error (Printf.sprintf "record-set!: index %d out of bounds for %s" i r.r_type.rt_name));
    r.r_fields.(i) <- new_val; Nil
  | _ -> raise (Eval_error ("record-set!: not a record, got " ^ type_of v))

(** [record_type_p v uid_val] — type predicate. 2-arg direct call.
    Named record_type_p because transpiler mangles record-type? to record_type_p. *)
let record_type_p v uid_val =
  match v with
  | Record r -> Bool (r.r_type.rt_uid = val_to_int uid_val)
  | _ -> Bool false

(** [record_p v] — generic record predicate.
    Named record_p because transpiler mangles record? to record_p. *)
let record_p v = Bool (is_record v)

(** [make_record_constructor rtd_uid] — returns a NativeFn that constructs records.
    Called from transpiled sf-define-record-type. *)
let make_record_constructor uid_val =
  let uid = val_to_int uid_val in
  let rt = match Hashtbl.find_opt rtd_table uid with
    | Some rt -> rt | None -> raise (Eval_error "make-record-constructor: unknown rtd") in
  NativeFn (rt.rt_name, fun args ->
    let n_ctor = Array.length rt.rt_ctor_map in
    let n_args = List.length args in
    if n_args <> n_ctor then
      raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d" rt.rt_name n_ctor n_args));
    let fields = Array.make (Array.length rt.rt_fields) Nil in
    List.iteri (fun i arg -> fields.(rt.rt_ctor_map.(i)) <- arg) args;
    Record { r_type = rt; r_fields = fields })

(** [make_record_predicate rtd_uid] — returns a NativeFn that tests record type. *)
let make_record_predicate uid_val =
  let uid = val_to_int uid_val in
  NativeFn ("?", fun args ->
    match args with
    | [Record r] -> Bool (r.r_type.rt_uid = uid)
    | [_] -> Bool false
    | _ -> raise (Eval_error "record predicate: expected 1 arg"))

(** [make_record_accessor field_idx] — returns a NativeFn that reads a field. *)
let make_record_accessor idx_val =
  let idx = val_to_int idx_val in
  NativeFn ("ref", fun args ->
    match args with
    | [Record r] ->
      if idx < 0 || idx >= Array.length r.r_fields then
        raise (Eval_error (Printf.sprintf "record accessor: index %d out of bounds" idx));
      r.r_fields.(idx)
    | [v] -> raise (Eval_error ("record accessor: not a record, got " ^ type_of v))
    | _ -> raise (Eval_error "record accessor: expected 1 arg"))

(** [make_record_mutator field_idx] — returns a NativeFn that sets a field. *)
let make_record_mutator idx_val =
  let idx = val_to_int idx_val in
  NativeFn ("set!", fun args ->
    match args with
    | [Record r; new_val] ->
      if idx < 0 || idx >= Array.length r.r_fields then
        raise (Eval_error (Printf.sprintf "record mutator: index %d out of bounds" idx));
      r.r_fields.(idx) <- new_val; Nil
    | _ -> raise (Eval_error "record mutator: expected (record value)"))


(** {1 R7RS parameter accessors — called from transpiled evaluator} *)

let parameter_p v = match v with Parameter _ -> Bool true | _ -> Bool false
let parameter_uid v = match v with
  | Parameter p -> String p.pm_uid
  | _ -> raise (Eval_error "parameter-uid: not a parameter")
let parameter_default v = match v with
  | Parameter p -> p.pm_default
  | _ -> raise (Eval_error "parameter-default: not a parameter")
let parameter_converter v = match v with
  | Parameter p -> (match p.pm_converter with Some c -> c | None -> Nil)
  | _ -> raise (Eval_error "parameter-converter: not a parameter")


(** {1 Dict operations} *)

let make_dict () : dict = Hashtbl.create 8

let dict_get (d : dict) key =
  match Hashtbl.find_opt d key with Some v -> v | None -> Nil

let dict_has (d : dict) key = Hashtbl.mem d key

let dict_set (d : dict) key v = Hashtbl.replace d key v

let dict_delete (d : dict) key = Hashtbl.remove d key

let dict_keys (d : dict) =
  Hashtbl.fold (fun k _ acc -> String k :: acc) d []

let dict_vals (d : dict) =
  Hashtbl.fold (fun _ v acc -> v :: acc) d []


(** {1 Value display} *)

(* Single shared buffer for the entire inspect recursion — eliminates
   the per-level [String.concat (List.map inspect ...)] allocation. *)
let rec inspect_into buf = function
  | Nil -> Buffer.add_string buf "nil"
  | Bool true -> Buffer.add_string buf "true"
  | Bool false -> Buffer.add_string buf "false"
  | Integer n -> Buffer.add_string buf (string_of_int n)
  | Number n -> Buffer.add_string buf (format_number n)
  | String s ->
    Buffer.add_char buf '"';
    String.iter (function
      | '"'  -> Buffer.add_string buf "\\\""
      | '\\' -> Buffer.add_string buf "\\\\"
      | '\n' -> Buffer.add_string buf "\\n"
      | '\r' -> Buffer.add_string buf "\\r"
      | '\t' -> Buffer.add_string buf "\\t"
      | c    -> Buffer.add_char buf c) s;
    Buffer.add_char buf '"'
  | Symbol s -> Buffer.add_string buf s
  | Keyword k -> Buffer.add_char buf ':'; Buffer.add_string buf k
  | List items | ListRef { contents = items } ->
    Buffer.add_char buf '(';
    (match items with
     | [] -> ()
     | x :: rest ->
       inspect_into buf x;
       List.iter (fun v -> Buffer.add_char buf ' '; inspect_into buf v) rest);
    Buffer.add_char buf ')'
  | Dict d ->
    Buffer.add_char buf '{';
    let first = ref true in
    Hashtbl.iter (fun k v ->
      if !first then first := false else Buffer.add_char buf ' ';
      Buffer.add_char buf ':'; Buffer.add_string buf k;
      Buffer.add_char buf ' '; inspect_into buf v) d;
    Buffer.add_char buf '}'
  | Lambda l ->
    let tag = match l.l_name with Some n -> n | None -> "lambda" in
    Buffer.add_char buf '<'; Buffer.add_string buf tag;
    Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " l.l_params);
    Buffer.add_string buf ")>"
  | Component c ->
    Buffer.add_string buf "<Component ~"; Buffer.add_string buf c.c_name;
    Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " c.c_params);
    Buffer.add_string buf ")>"
  | Island i ->
    Buffer.add_string buf "<Island ~"; Buffer.add_string buf i.i_name;
    Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " i.i_params);
    Buffer.add_string buf ")>"
  | Macro m ->
    let tag = match m.m_name with Some n -> n | None -> "macro" in
    Buffer.add_char buf '<'; Buffer.add_string buf tag;
    Buffer.add_char buf '('; Buffer.add_string buf (String.concat ", " m.m_params);
    Buffer.add_string buf ")>"
  | Thunk _ -> Buffer.add_string buf "<thunk>"
  | Continuation (_, _) -> Buffer.add_string buf "<continuation>"
  | CallccContinuation (_, _) -> Buffer.add_string buf "<callcc-continuation>"
  | NativeFn (name, _) ->
    Buffer.add_string buf "<native:"; Buffer.add_string buf name; Buffer.add_char buf '>'
  | Signal _ -> Buffer.add_string buf "<signal>"
  | RawHTML s ->
    Buffer.add_string buf "\"<raw-html:";
    Buffer.add_string buf (string_of_int (String.length s));
    Buffer.add_string buf ">\""
  | Spread _ -> Buffer.add_string buf "<spread>"
  | SxExpr s ->
    Buffer.add_string buf "\"<sx-expr:";
    Buffer.add_string buf (string_of_int (String.length s));
    Buffer.add_string buf ">\""
  | Env _ -> Buffer.add_string buf "<env>"
  | CekState _ -> Buffer.add_string buf "<cek-state>"
  | CekFrame f ->
    Buffer.add_string buf "<frame:"; Buffer.add_string buf f.cf_type; Buffer.add_char buf '>'
  | VmClosure cl ->
    Buffer.add_string buf "<vm:";
    Buffer.add_string buf (match cl.vm_name with Some n -> n | None -> "anon");
    Buffer.add_char buf '>'
  | Record r ->
    Buffer.add_string buf "<record:"; Buffer.add_string buf r.r_type.rt_name;
    Array.iteri (fun i v ->
      Buffer.add_char buf ' ';
      Buffer.add_string buf r.r_type.rt_fields.(i);
      Buffer.add_char buf '=';
      inspect_into buf v) r.r_fields;
    Buffer.add_char buf '>'
  | Parameter p ->
    Buffer.add_string buf "<parameter:"; Buffer.add_string buf p.pm_uid; Buffer.add_char buf '>'
  | Vector arr ->
    Buffer.add_string buf "#(";
    Array.iteri (fun i v ->
      if i > 0 then Buffer.add_char buf ' ';
      inspect_into buf v) arr;
    Buffer.add_char buf ')'
  | VmFrame f ->
    Buffer.add_string buf (Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base)
  | VmMachine m ->
    Buffer.add_string buf (Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames))
  | StringBuffer b ->
    Buffer.add_string buf (Printf.sprintf "<string-buffer:%d>" (Buffer.length b))
  | HashTable ht ->
    Buffer.add_string buf (Printf.sprintf "<hash-table:%d>" (Hashtbl.length ht))
  | Char n ->
    Buffer.add_string buf "#\\";
    (match n with
     | 32 -> Buffer.add_string buf "space"
     | 10 -> Buffer.add_string buf "newline"
     | 9 -> Buffer.add_string buf "tab"
     | 13 -> Buffer.add_string buf "return"
     | 0 -> Buffer.add_string buf "nul"
     | 27 -> Buffer.add_string buf "escape"
     | 127 -> Buffer.add_string buf "delete"
     | 8 -> Buffer.add_string buf "backspace"
     | _ -> Buffer.add_utf_8_uchar buf (Uchar.of_int n))
  | Eof -> Buffer.add_string buf "#!eof"
  | Port { sp_kind = PortInput (_, pos); sp_closed } ->
    Buffer.add_string buf (Printf.sprintf "<input-port:pos=%d%s>" !pos (if sp_closed then ":closed" else ""))
  | Port { sp_kind = PortOutput b; sp_closed } ->
    Buffer.add_string buf (Printf.sprintf "<output-port:len=%d%s>" (Buffer.length b) (if sp_closed then ":closed" else ""))
  | Rational (n, d) ->
    Buffer.add_string buf (string_of_int n); Buffer.add_char buf '/';
    Buffer.add_string buf (string_of_int d)
  | SxSet ht ->
    Buffer.add_string buf (Printf.sprintf "<set:%d>" (Hashtbl.length ht))
  | SxRegexp (src, flags, _) ->
    Buffer.add_string buf "#/"; Buffer.add_string buf src;
    Buffer.add_char buf '/'; Buffer.add_string buf flags
  | SxBytevector b ->
    Buffer.add_string buf "#u8(";
    let n = Bytes.length b in
    for i = 0 to n - 1 do
      if i > 0 then Buffer.add_char buf ' ';
      Buffer.add_string buf (string_of_int (Char.code (Bytes.get b i)))
    done;
    Buffer.add_char buf ')'
  | AdtValue a ->
    Buffer.add_char buf '('; Buffer.add_string buf a.av_ctor;
    Array.iter (fun v -> Buffer.add_char buf ' '; inspect_into buf v) a.av_fields;
    Buffer.add_char buf ')'

let inspect v =
  let buf = Buffer.create 64 in
  inspect_into buf v;
  Buffer.contents buf
