rose-ash/hosts/ocaml/lib/sx_ref.ml

(* sx_ref.ml — Auto-generated from SX spec by hosts/ocaml/bootstrap.py *)
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap.py *)

[@@@warning "-26-27"]

open Sx_types
open Sx_runtime

(* Trampoline — forward ref, resolved after eval_expr is defined. *)
let trampoline_fn : (value -> value) ref = ref (fun v -> v)
let trampoline v = !trampoline_fn v



(* === Mutable globals — backing refs for transpiler's !_ref / _ref := === *)
let _strict_ref = ref (Bool false)
let _prim_param_types_ref = ref Nil
let _last_error_kont_ref = ref Nil
let _protocol_registry_ = Dict (Hashtbl.create 0)



(* === Transpiled from evaluator (frames + eval + CEK) === *)

(* make-cek-state *)
let rec make_cek_state control env kont =
  (CekState { cs_control = control; cs_env = env; cs_kont = kont; cs_phase = "eval"; cs_value = Nil })

(* make-cek-value *)
and make_cek_value value env kont =
  (CekState { cs_control = Nil; cs_env = env; cs_kont = kont; cs_phase = "continue"; cs_value = value })

(* make-cek-suspended *)
and make_cek_suspended request env kont =
  (let _d = Hashtbl.create 4 in Hashtbl.replace _d "env" env; Hashtbl.replace _d "kont" kont; Hashtbl.replace _d "phase" (String "io-suspended"); Hashtbl.replace _d "request" request; Dict _d)

(* cek-terminal? *)
and cek_terminal_p state =
  (let _and = (prim_call "=" [(get (state) ((String "phase"))); (String "continue")]) in if not (sx_truthy _and) then _and else (empty_p ((get (state) ((String "kont"))))))

(* cek-suspended? *)
and cek_suspended_p state =
  (prim_call "=" [(get (state) ((String "phase"))); (String "io-suspended")])

(* cek-control *)
and cek_control s =
  (get (s) ((String "control")))

(* cek-env *)
and cek_env s =
  (get (s) ((String "env")))

(* cek-kont *)
and cek_kont s =
  (get (s) ((String "kont")))

(* cek-phase *)
and cek_phase s =
  (get (s) ((String "phase")))

(* cek-io-request *)
and cek_io_request s =
  (get (s) ((String "request")))

(* cek-value *)
and cek_value s =
  (get (s) ((String "value")))

(* make-if-frame *)
and make_if_frame then_expr else_expr env =
  (CekFrame { cf_type = "if"; cf_env = env; cf_name = else_expr; cf_body = then_expr; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-when-frame *)
and make_when_frame body_exprs env =
  (CekFrame { cf_type = "when"; cf_env = env; cf_name = Nil; cf_body = body_exprs; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-begin-frame *)
and make_begin_frame remaining env =
  (CekFrame { cf_type = "begin"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-let-frame *)
and make_let_frame name remaining body local =
  (CekFrame { cf_type = "let"; cf_env = local; cf_name = name; cf_body = body; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-define-frame *)
and make_define_frame name env has_effects effect_list =
  (CekFrame { cf_type = "define"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = has_effects; cf_extra2 = effect_list })

(* make-set-frame *)
and make_set_frame name env =
  (CekFrame { cf_type = "set"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-arg-frame *)
and make_arg_frame f evaled remaining env raw_args head_name =
  (CekFrame { cf_type = "arg"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = evaled; cf_results = raw_args; cf_extra = (let _or = head_name in if sx_truthy _or then _or else Nil); cf_extra2 = Nil })

(* make-call-frame *)
and make_call_frame f args env =
  (CekFrame { cf_type = "call"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = f; cf_args = args; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-cond-frame *)
and make_cond_frame remaining env scheme_p =
  (CekFrame { cf_type = "cond"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = scheme_p; cf_extra2 = Nil })

(* make-cond-arrow-frame *)
and make_cond_arrow_frame test_value env =
  (CekFrame { cf_type = "cond-arrow"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = test_value; cf_extra2 = Nil })

(* make-case-frame *)
and make_case_frame match_val remaining env =
  (CekFrame { cf_type = "case"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = match_val; cf_extra2 = Nil })

(* make-thread-frame *)
and make_thread_frame remaining env mode name =
  (CekFrame { cf_type = "thread"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = mode; cf_extra2 = Nil })

(* thread-insert-arg *)
and thread_insert_arg form value fenv =
  (if sx_truthy ((prim_call "=" [(type_of (form)); (String "list")])) then (eval_expr ((cons ((first (form))) ((cons ((List [(Symbol "quote"); value])) ((rest (form))))))) (fenv)) else (eval_expr ((List [form; (List [(Symbol "quote"); value])])) (fenv)))

(* thread-insert-arg-last *)
and thread_insert_arg_last form value fenv =
  (if sx_truthy ((prim_call "=" [(type_of (form)); (String "list")])) then (eval_expr ((prim_call "append" [form; (List [(List [(Symbol "quote"); value])])])) (fenv)) else (eval_expr ((List [form; (List [(Symbol "quote"); value])])) (fenv)))

(* make-map-frame *)
and make_map_frame f remaining results env =
  (CekFrame { cf_type = "map"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = results; cf_extra = (Bool false); cf_extra2 = Nil })

(* make-map-indexed-frame *)
and make_map_indexed_frame f remaining results env =
  (CekFrame { cf_type = "map"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = results; cf_extra = (Bool true); cf_extra2 = Nil })

(* make-multi-map-frame *)
and make_multi_map_frame f remaining_lists results env =
  (CekFrame { cf_type = "multi-map"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining_lists; cf_f = f; cf_args = Nil; cf_results = results; cf_extra = Nil; cf_extra2 = Nil })

(* make-filter-frame *)
and make_filter_frame f remaining results current_item env =
  (CekFrame { cf_type = "filter"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = results; cf_extra = current_item; cf_extra2 = Nil })

(* make-reduce-frame *)
and make_reduce_frame f remaining env =
  (CekFrame { cf_type = "reduce"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-for-each-frame *)
and make_for_each_frame f remaining env =
  (CekFrame { cf_type = "for-each"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-some-frame *)
and make_some_frame f remaining env =
  (CekFrame { cf_type = "some"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-every-frame *)
and make_every_frame f remaining env =
  (CekFrame { cf_type = "every"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-scope-frame *)
and make_scope_frame name remaining env =
  (CekFrame { cf_type = "scope"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-provide-frame *)
and make_provide_frame name value remaining env =
  (CekFrame { cf_type = "provide"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = value; cf_extra2 = Nil })

(* make-scope-acc-frame *)
and make_scope_acc_frame name value remaining env =
  (CekFrame { cf_type = "scope-acc"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = (let _or = value in if sx_truthy _or then _or else Nil); cf_extra2 = (List []) })

(* make-reset-frame *)
and make_reset_frame env =
  (CekFrame { cf_type = "reset"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-dict-frame *)
and make_dict_frame remaining results env =
  (CekFrame { cf_type = "dict"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = results; cf_extra = Nil; cf_extra2 = Nil })

(* make-and-frame *)
and make_and_frame remaining env =
  (CekFrame { cf_type = "and"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-or-frame *)
and make_or_frame remaining env =
  (CekFrame { cf_type = "or"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-dynamic-wind-frame *)
and make_dynamic_wind_frame phase body_thunk after_thunk env =
  (CekFrame { cf_type = "dynamic-wind"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = phase; cf_extra2 = Nil })

(* make-reactive-reset-frame *)
and make_reactive_reset_frame env update_fn first_render_p =
  (CekFrame { cf_type = "reactive-reset"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = update_fn; cf_extra2 = first_render_p })

(* make-callcc-frame *)
and make_callcc_frame env =
  (CekFrame { cf_type = "callcc"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-deref-frame *)
and make_deref_frame env =
  (CekFrame { cf_type = "deref"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-ho-setup-frame *)
and make_ho_setup_frame ho_type remaining_args evaled_args env =
  (CekFrame { cf_type = "ho-setup"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining_args; cf_f = Nil; cf_args = evaled_args; cf_results = Nil; cf_extra = ho_type; cf_extra2 = Nil })

(* make-comp-trace-frame *)
and make_comp_trace_frame name file =
  (CekFrame { cf_type = "comp-trace"; cf_env = file; cf_name = name; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* kont-collect-comp-trace *)
and kont_collect_comp_trace kont =
  (if sx_truthy ((empty_p (kont))) then (List []) else (let frame = (first (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "comp-trace")])) then (cons ((let _d = Hashtbl.create 2 in Hashtbl.replace _d "file" (get (frame) ((String "file"))); Hashtbl.replace _d "name" (get (frame) ((String "name"))); Dict _d)) ((kont_collect_comp_trace ((rest (kont)))))) else (kont_collect_comp_trace ((rest (kont)))))))

(* make-handler-frame *)
and make_handler_frame handlers remaining env =
  (CekFrame { cf_type = "handler"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = handlers; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-restart-frame *)
and make_restart_frame restarts remaining env =
  (CekFrame { cf_type = "restart"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = restarts; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-signal-return-frame *)
and make_signal_return_frame env saved_kont =
  (CekFrame { cf_type = "signal-return"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = saved_kont; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-raise-eval-frame *)
and make_raise_eval_frame env continuable_p =
  (CekFrame { cf_type = "raise-eval"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = continuable_p; cf_extra2 = Nil })

(* make-raise-guard-frame *)
and make_raise_guard_frame env saved_kont =
  (CekFrame { cf_type = "raise-guard"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = saved_kont; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-perform-frame *)
and make_perform_frame env =
  (CekFrame { cf_type = "perform"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-vm-resume-frame *)
and make_vm_resume_frame resume_fn env =
  (CekFrame { cf_type = "vm-resume"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = resume_fn; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-import-frame *)
and make_import_frame import_set remaining_sets env =
  (CekFrame { cf_type = "import"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining_sets; cf_f = Nil; cf_args = import_set; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })

(* make-parameterize-frame *)
and make_parameterize_frame remaining current_param results body env =
  (CekFrame { cf_type = "parameterize"; cf_env = env; cf_name = Nil; cf_body = body; cf_remaining = remaining; cf_f = current_param; cf_args = Nil; cf_results = results; cf_extra = Nil; cf_extra2 = Nil })

(* find-matching-handler *)
and find_matching_handler handlers condition =
  (if sx_truthy ((empty_p (handlers))) then Nil else (let pair = (first (handlers)) in (let pred = (first (pair)) in let handler_fn = (nth (pair) ((Number 1.0))) in (if sx_truthy ((cek_call (pred) ((List [condition])))) then handler_fn else (find_matching_handler ((rest (handlers))) (condition))))))

(* kont-find-handler *)
and kont_find_handler kont condition =
  (if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "handler")])) then (let match' = (find_matching_handler ((get (frame) ((String "f")))) (condition)) in (if sx_truthy ((is_nil (match'))) then (kont_find_handler ((rest (kont))) (condition)) else match')) else (kont_find_handler ((rest (kont))) (condition)))))

(* find-named-restart *)
and find_named_restart restarts name =
  (if sx_truthy ((empty_p (restarts))) then Nil else (let entry = (first (restarts)) in (if sx_truthy ((prim_call "=" [(first (entry)); name])) then entry else (find_named_restart ((rest (restarts))) (name)))))

(* kont-find-restart *)
and kont_find_restart kont name =
  (if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "restart")])) then (let match' = (find_named_restart ((get (frame) ((String "f")))) (name)) in (if sx_truthy ((is_nil (match'))) then (kont_find_restart ((rest (kont))) (name)) else (List [match'; frame; (rest (kont))]))) else (kont_find_restart ((rest (kont))) (name)))))

(* frame-type *)
and frame_type f =
  (get (f) ((String "type")))

(* kont-push *)
and kont_push frame kont =
  (cons (frame) (kont))

(* kont-top *)
and kont_top kont =
  (first (kont))

(* kont-pop *)
and kont_pop kont =
  (rest (kont))

(* kont-empty? *)
and kont_empty_p kont =
  (empty_p (kont))

(* kont-capture-to-reset *)
and kont_capture_to_reset kont =
  (let rec scan = (fun k captured -> (if sx_truthy ((empty_p (k))) then (raise (Eval_error (value_to_str (String "shift without enclosing reset")))) else (let frame = (first (k)) in (if sx_truthy ((let _or = (prim_call "=" [(frame_type (frame)); (String "reset")]) in if sx_truthy _or then _or else (prim_call "=" [(frame_type (frame)); (String "reactive-reset")]))) then (List [captured; (rest (k))]) else (scan ((rest (k))) ((prim_call "append" [captured; (List [frame])]))))))) in (scan (kont) ((List []))))

(* kont-push-provides *)
and kont_push_provides pairs env kont =
  (if sx_truthy ((empty_p (pairs))) then kont else (let pair = (first (pairs)) in (kont_push_provides ((rest (pairs))) (env) ((cons ((make_provide_frame ((first (pair))) ((nth (pair) ((Number 1.0)))) ((List [])) (env))) (kont))))))

(* kont-find-provide *)
and kont_find_provide kont name =
  (if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((let _and = (prim_call "=" [(frame_type (frame)); (String "provide")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(get (frame) ((String "name"))); name]))) then frame else (kont_find_provide ((rest (kont))) (name)))))

(* kont-find-scope-acc *)
and kont_find_scope_acc kont name =
  (if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((let _and = (prim_call "=" [(frame_type (frame)); (String "scope-acc")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(get (frame) ((String "name"))); name]))) then frame else (kont_find_scope_acc ((rest (kont))) (name)))))

(* has-reactive-reset-frame? *)
and has_reactive_reset_frame_p kont =
  (if sx_truthy ((empty_p (kont))) then (Bool false) else (if sx_truthy ((prim_call "=" [(frame_type ((first (kont)))); (String "reactive-reset")])) then (Bool true) else (has_reactive_reset_frame_p ((rest (kont))))))

(* kont-capture-to-reactive-reset *)
and kont_capture_to_reactive_reset kont =
  (let rec scan = (fun k captured -> (if sx_truthy ((empty_p (k))) then (raise (Eval_error (value_to_str (String "reactive deref without enclosing reactive-reset")))) else (let frame = (first (k)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "reactive-reset")])) then (List [captured; frame; (rest (k))]) else (scan ((rest (k))) ((prim_call "append" [captured; (List [frame])]))))))) in (scan (kont) ((List []))))

(* *custom-special-forms* *)
and custom_special_forms =
  (Dict (Hashtbl.create 0))

(* register-special-form! *)
and register_special_form name handler =
  (sx_dict_set_b custom_special_forms name handler)

(* *render-check* *)
and render_check =
  Nil

(* *render-fn* *)
and render_fn =
  Nil

(* *library-registry* *)
and _library_registry_ =
  (Dict (Hashtbl.create 0))

(* library-name-key *)
and library_name_key spec =
  (prim_call "join" [(String "."); (List (List.map (fun s -> (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s])))) (sx_to_list spec)))])

(* library-loaded? *)
and library_loaded_p spec =
  (prim_call "has-key?" [_library_registry_; (library_name_key (spec))])

(* library-exports *)
and library_exports spec =
  (get ((get (_library_registry_) ((library_name_key (spec))))) ((String "exports")))

(* register-library *)
and register_library spec exports =
  (sx_dict_set_b _library_registry_ (library_name_key (spec)) (let _d = Hashtbl.create 1 in Hashtbl.replace _d "exports" exports; Dict _d))

(* *io-registry* *)
and _io_registry_ =
  (Dict (Hashtbl.create 0))

(* io-register! *)
and io_register_b name spec =
  (sx_dict_set_b _io_registry_ name spec)

(* io-registered? *)
and io_registered_p name =
  (prim_call "has-key?" [_io_registry_; name])

(* io-lookup *)
and io_lookup name =
  (get (_io_registry_) (name))

(* io-names *)
and io_names () =
  (prim_call "keys" [_io_registry_])

(* step-sf-io *)
and step_sf_io args env kont =
  (let name = (first (args)) in let io_args = (rest (args)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((io_registered_p (name))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "io: unknown operation '"); name; (String "' — not in *io-registry*")]))))) else Nil)) in (make_cek_state ((cons ((Symbol "perform")) ((List [(let _d = Hashtbl.create 2 in Hashtbl.replace _d "args" io_args; Hashtbl.replace _d "op" name; Dict _d)])))) (env) (kont))))

(* *strict* *)
and _strict_ =
  !_strict_ref

(* set-strict! *)
and set_strict_b val' =
  let _strict_ = ref Nil in (_strict_ref := val'; Nil)

(* *prim-param-types* *)
and _prim_param_types_ =
  !_prim_param_types_ref

(* set-prim-param-types! *)
and set_prim_param_types_b types =
  let _prim_param_types_ = ref Nil in (_prim_param_types_ref := types; Nil)

(* value-matches-type? *)
and value_matches_type_p val' expected_type =
  (let _match_val = expected_type in (if sx_truthy ((prim_call "=" [_match_val; (String "any")])) then (Bool true) else (if sx_truthy ((prim_call "=" [_match_val; (String "number")])) then (number_p (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "string")])) then (string_p (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "boolean")])) then (boolean_p (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "nil")])) then (is_nil (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "list")])) then (list_p (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "dict")])) then (dict_p (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "lambda")])) then (is_lambda (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "symbol")])) then (prim_call "=" [(type_of (val')); (String "symbol")]) else (if sx_truthy ((prim_call "=" [_match_val; (String "keyword")])) then (prim_call "=" [(type_of (val')); (String "keyword")]) else (if sx_truthy ((let _and = (string_p (expected_type)) in if not (sx_truthy _and) then _and else (prim_call "ends-with?" [expected_type; (String "?")]))) then (let _or = (is_nil (val')) in if sx_truthy _or then _or else (value_matches_type_p (val') ((prim_call "slice" [expected_type; (Number 0.0); (prim_call "-" [(prim_call "string-length" [expected_type]); (Number 1.0)])])))) else (Bool true)))))))))))))

(* strict-check-args *)
and strict_check_args name args =
  (if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else !_prim_param_types_ref)) then (let spec = (get (!_prim_param_types_ref) (name)) in (if sx_truthy (spec) then (let positional = (get (spec) ((String "positional"))) in let rest_type = (get (spec) ((String "rest-type"))) in (let () = ignore ((if sx_truthy (positional) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let param = (nth (pair) ((Number 1.0))) in let p_name = (first (param)) in let p_type = (nth (param) ((Number 1.0))) in (if sx_truthy ((prim_call "<" [idx; (len (args))])) then (let val' = (nth (args) (idx)) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (p_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); p_type; (String " for param "); p_name; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [i; p])) (sx_to_list positional)))); Nil) else Nil)) in (if sx_truthy ((let _and = rest_type in if not (sx_truthy _and) then _and else (prim_call ">" [(len (args)); (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let val' = (nth (pair) ((Number 1.0))) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (rest_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); rest_type; (String " for rest arg "); idx; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)))) (sx_to_list (List (List.mapi (fun i v -> let i = Number (float_of_int i) in (List [i; v])) (sx_to_list (prim_call "slice" [args; (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))))); Nil) else Nil))) else Nil)) else Nil)

(* bind-lambda-params *)
and bind_lambda_params params args local =
  (let rest_idx = (prim_call "index-of" [params; (String "&rest")]) in (if sx_truthy ((let _and = (number_p (rest_idx)) in if not (sx_truthy _and) then _and else (prim_call "<" [rest_idx; (len (params))]))) then (let positional = (prim_call "slice" [params; (Number 0.0); rest_idx]) in let rest_name = (nth (params) ((prim_call "+" [rest_idx; (Number 1.0)]))) in (let () = ignore ((for_each_indexed ((NativeFn ("\206\187", fun _args -> match _args with [i; p] -> (fun i p -> (env_bind local (sx_to_string p) (if sx_truthy ((prim_call "<" [i; (len (args))])) then (nth (args) (i)) else Nil))) i p | _ -> Nil))) (positional))) in (let () = ignore ((env_bind local (sx_to_string rest_name) (if sx_truthy ((prim_call ">" [(len (args)); rest_idx])) then (prim_call "slice" [args; rest_idx]) else (List [])))) in (Bool true)))) else (Bool false)))

(* call-lambda *)
and call_lambda f args caller_env =
  (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (caller_env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (make_thunk ((lambda_body (f))) (local))))

(* call-component *)
and call_component comp raw_args env =
  (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (comp))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (comp))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (comp))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_thunk ((component_body (comp))) (local)))))

(* parse-keyword-args *)
and parse_keyword_args raw_args env =
  (let kwargs = (Dict (Hashtbl.create 0)) in let children = ref ((List [])) in let i = (Number 0.0) in (let () = ignore ((List.fold_left (fun state arg -> (let idx = (get (state) ((String "i"))) in let skip = (get (state) ((String "skip"))) in (if sx_truthy (skip) then (prim_call "assoc" [state; (String "skip"); (Bool false); (String "i"); (prim_call "inc" [idx])]) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (arg)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "<" [(prim_call "inc" [idx]); (len (raw_args))]))) then (let () = ignore ((sx_dict_set_b kwargs (keyword_name (arg)) (trampoline ((eval_expr ((nth (raw_args) ((prim_call "inc" [idx])))) (env)))))) in (prim_call "assoc" [state; (String "skip"); (Bool true); (String "i"); (prim_call "inc" [idx])])) else (let () = ignore ((children := sx_append_b !children (trampoline ((eval_expr (arg) (env)))); Nil)) in (prim_call "assoc" [state; (String "i"); (prim_call "inc" [idx])])))))) (let _d = Hashtbl.create 2 in Hashtbl.replace _d (value_to_str (String "i")) (Number 0.0); Hashtbl.replace _d (value_to_str (String "skip")) (Bool false);  Dict _d) (sx_to_list raw_args))) in (List [kwargs; !children])))

(* cond-scheme? *)
and cond_scheme_p clauses =
  (Bool (List.for_all (fun c -> sx_truthy ((let _and = (prim_call "=" [(type_of (c)); (String "list")]) in if not (sx_truthy _and) then _and else (let _or = (prim_call "=" [(len (c)); (Number 2.0)]) in if sx_truthy _or then _or else (let _and = (prim_call "=" [(len (c)); (Number 3.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (c) ((Number 1.0))))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (c) ((Number 1.0))))); (String "=>")]))))))) (sx_to_list clauses)))

(* is-else-clause? *)
and is_else_clause test =
  (let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (let _and = (prim_call "=" [(type_of (test)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _or = (prim_call "=" [(symbol_name (test)); (String "else")]) in if sx_truthy _or then _or else (prim_call "=" [(symbol_name (test)); (String ":else")]))))

(* sf-named-let *)
and sf_named_let args env =
  (let loop_name = (symbol_name ((first (args)))) in let bindings = (nth (args) ((Number 1.0))) in let body = (prim_call "slice" [args; (Number 2.0)]) in let params = ref ((List [])) in let inits = ref ((List [])) in (let () = ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (List.iter (fun binding -> ignore ((let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))); Nil)) in (inits := sx_append_b !inits (nth (binding) ((Number 1.0))); Nil)))) (sx_to_list bindings); Nil) else (List.fold_left (fun _acc pair_idx -> (let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))); (String "symbol")])) then (symbol_name ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))) else (nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)])))); Nil)) in (inits := sx_append_b !inits (nth (bindings) ((prim_call "inc" [(prim_call "*" [pair_idx; (Number 2.0)])]))); Nil))) Nil (sx_to_list (prim_call "range" [(Number 0.0); (prim_call "/" [(len (bindings)); (Number 2.0)])]))))) in (let loop_body = (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (first (body)) else (cons ((make_symbol ((String "begin")))) (body))) in let loop_fn = (make_lambda (!params) (loop_body) (env)) in (let () = ignore ((set_lambda_name loop_fn (sx_to_string loop_name))) in (let () = ignore ((env_bind (lambda_closure (loop_fn)) (sx_to_string loop_name) loop_fn)) in (let init_vals = (List (List.map (fun e -> (trampoline ((eval_expr (e) (env))))) (sx_to_list !inits))) in (cek_call (loop_fn) (init_vals))))))))

(* sf-lambda *)
and sf_lambda args env =
  (let params_expr = (first (args)) in let body_exprs = (rest (args)) in let body = (if sx_truthy ((prim_call "=" [(len (body_exprs)); (Number 1.0)])) then (first (body_exprs)) else (cons ((make_symbol ((String "begin")))) (body_exprs))) in let param_names = (List (List.map (fun p -> (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (p)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (p)); (Number 3.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (p) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (p) ((Number 1.0))))); (String "as")]))))) then (symbol_name ((first (p)))) else p))) (sx_to_list params_expr))) in (make_lambda (param_names) (body) (env)))

(* sf-defcomp *)
and sf_defcomp args env =
  (let name_sym = (first (args)) in let params_raw = (nth (args) ((Number 1.0))) in let body = (last (args)) in let comp_name = (strip_prefix ((symbol_name (name_sym))) ((String "~"))) in let parsed = (parse_comp_params (params_raw)) in let params = (first (parsed)) in let has_children = (nth (parsed) ((Number 1.0))) in let param_types = (nth (parsed) ((Number 2.0))) in let affinity = (defcomp_kwarg (args) ((String "affinity")) ((String "auto"))) in (let comp = (make_component (comp_name) (params) (has_children) (body) (env) (affinity)) in let effects = (defcomp_kwarg (args) ((String "effects")) (Nil)) in (let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy ((is_nil (param_types)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((empty_p ((prim_call "keys" [param_types]))))))))) then (component_set_param_types_b (comp) (param_types)) else Nil)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((is_nil (effects))))))) then (let effect_list = (if sx_truthy ((prim_call "=" [(type_of (effects)); (String "list")])) then (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else (String (sx_str [e])))) (sx_to_list effects))) else (List [(String (sx_str [effects]))])) in let effect_anns = (if sx_truthy ((env_has (env) ((String "*effect-annotations*")))) then (env_get (env) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns (symbol_name (name_sym)) effect_list)) in (env_bind env (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (let () = ignore ((if sx_truthy ((env_has (env) ((String "*current-file*")))) then (component_set_file_b (comp) ((env_get (env) ((String "*current-file*"))))) else Nil)) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) comp)) in comp))))))

(* defcomp-kwarg *)
and defcomp_kwarg args key default =
  (let end' = (prim_call "-" [(len (args)); (Number 1.0)]) in let result' = ref (default) in (let () = ignore ((List.iter (fun i -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of ((nth (args) (i)))); (String "keyword")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(keyword_name ((nth (args) (i)))); key]) in if not (sx_truthy _and) then _and else (prim_call "<" [(prim_call "+" [i; (Number 1.0)]); end'])))) then (let val' = (nth (args) ((prim_call "+" [i; (Number 1.0)]))) in (result' := (if sx_truthy ((prim_call "=" [(type_of (val')); (String "keyword")])) then (keyword_name (val')) else val'); Nil)) else Nil))) (sx_to_list (prim_call "range" [(Number 2.0); end'; (Number 1.0)])); Nil)) in !result'))

(* parse-comp-params *)
and parse_comp_params params_expr =
  (let params = ref ((List [])) in let param_types = (Dict (Hashtbl.create 0)) in let has_children = ref ((Bool false)) in let in_key = ref ((Bool false)) in (let () = ignore ((List.iter (fun p -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (p)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (p)); (Number 3.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (p)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (p) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (p) ((Number 1.0))))); (String "as")])))))) then (let name = (symbol_name ((first (p)))) in let ptype = (nth (p) ((Number 2.0))) in (let type_val = (if sx_truthy ((prim_call "=" [(type_of (ptype)); (String "symbol")])) then (symbol_name (ptype)) else ptype) in (if sx_truthy ((Bool (not (sx_truthy (!has_children))))) then (let () = ignore ((params := sx_append_b !params name; Nil)) in (sx_dict_set_b param_types name type_val)) else Nil))) else (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (let name = (symbol_name (p)) in (if sx_truthy ((prim_call "=" [name; (String "&key")])) then (in_key := (Bool true); Nil) else (if sx_truthy ((prim_call "=" [name; (String "&rest")])) then (has_children := (Bool true); Nil) else (if sx_truthy ((prim_call "=" [name; (String "&children")])) then (has_children := (Bool true); Nil) else (if sx_truthy (!has_children) then Nil else (if sx_truthy (!in_key) then (params := sx_append_b !params name; Nil) else (params := sx_append_b !params name; Nil))))))) else Nil)))) (sx_to_list params_expr); Nil)) in (List [!params; !has_children; param_types])))

(* sf-defisland *)
and sf_defisland args env =
  (let name_sym = (first (args)) in let params_raw = (nth (args) ((Number 1.0))) in let body_exprs = (prim_call "slice" [args; (Number 2.0)]) in let body = (if sx_truthy ((prim_call "=" [(len (body_exprs)); (Number 1.0)])) then (first (body_exprs)) else (cons ((make_symbol ((String "begin")))) (body_exprs))) in let comp_name = (strip_prefix ((symbol_name (name_sym))) ((String "~"))) in let parsed = (parse_comp_params (params_raw)) in let params = (first (parsed)) in let has_children = (nth (parsed) ((Number 1.0))) in (let island = (make_island (comp_name) (params) (has_children) (body) (env)) in (let () = ignore ((if sx_truthy ((env_has (env) ((String "*current-file*")))) then (component_set_file_b (island) ((env_get (env) ((String "*current-file*"))))) else Nil)) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) island)) in island))))

(* defio-parse-kwargs! *)
and defio_parse_kwargs_b spec remaining =
  (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (remaining)))))) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (remaining)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (keyword_p ((first (remaining))))))) then (let () = ignore ((sx_dict_set_b spec (keyword_name ((first (remaining)))) (nth (remaining) ((Number 1.0))))) in (defio_parse_kwargs_b (spec) ((rest ((rest (remaining))))))) else Nil)

(* sf-defio *)
and sf_defio args env =
  (let name = (first (args)) in let spec = (Dict (Hashtbl.create 0)) in (let () = ignore ((sx_dict_set_b spec (String "name") name)) in (let () = ignore ((defio_parse_kwargs_b (spec) ((rest (args))))) in (let () = ignore ((io_register_b (name) (spec))) in spec))))

(* sf-defmacro *)
and sf_defmacro args env =
  (let name_sym = (first (args)) in let params_raw = (nth (args) ((Number 1.0))) in let body = (nth (args) ((Number 2.0))) in let parsed = (parse_macro_params (params_raw)) in let params = (first (parsed)) in let rest_param = (nth (parsed) ((Number 1.0))) in (let mac = (make_macro (params) (rest_param) (body) (env) ((symbol_name (name_sym)))) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) mac)) in mac)))

(* parse-macro-params *)
and parse_macro_params params_expr =
  (let params = ref ((List [])) in let rest_param = ref (Nil) in (let () = ignore ((List.fold_left (fun state p -> (if sx_truthy ((let _and = (prim_call "=" [(type_of (p)); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (p)); (String "&rest")]))) then (prim_call "assoc" [state; (String "in-rest"); (Bool true)]) else (if sx_truthy ((get (state) ((String "in-rest")))) then (let () = ignore ((rest_param := (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else p); Nil)) in state) else (let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else p); Nil)) in state)))) (let _d = Hashtbl.create 1 in Hashtbl.replace _d (value_to_str (String "in-rest")) (Bool false);  Dict _d) (sx_to_list params_expr))) in (List [!params; !rest_param])))

(* qq-expand *)
and qq_expand template env =
  (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (template)); (String "list")])))))) then template else (if sx_truthy ((empty_p (template))) then (List []) else (let head = (first (template)) in (if sx_truthy ((let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (head)); (String "unquote")]))) then (trampoline ((eval_expr ((nth (template) ((Number 1.0)))) (env)))) else (List.fold_left (fun result' item -> (if sx_truthy ((let _and = (prim_call "=" [(type_of (item)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (item)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (item)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (item)))); (String "splice-unquote")]))))) then (let spliced = (trampoline ((eval_expr ((nth (item) ((Number 1.0)))) (env)))) in (if sx_truthy ((prim_call "=" [(type_of (spliced)); (String "list")])) then (prim_call "concat" [result'; spliced]) else (if sx_truthy ((is_nil (spliced))) then result' else (prim_call "concat" [result'; (List [spliced])])))) else (prim_call "concat" [result'; (List [(qq_expand (item) (env))])]))) (List []) (sx_to_list template))))))

(* sf-letrec *)
and sf_letrec args env =
  (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in let names = ref ((List [])) in let val_exprs = ref ((List [])) in (let () = ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (List.iter (fun binding -> ignore ((let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))) in (let () = ignore ((names := sx_append_b !names vname; Nil)) in (let () = ignore ((val_exprs := sx_append_b !val_exprs (nth (binding) ((Number 1.0))); Nil)) in (env_bind local (sx_to_string vname) Nil)))))) (sx_to_list bindings); Nil) else (List.fold_left (fun _acc pair_idx -> (let vname = (if sx_truthy ((prim_call "=" [(type_of ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))); (String "symbol")])) then (symbol_name ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))) else (nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)])))) in let val_expr = (nth (bindings) ((prim_call "inc" [(prim_call "*" [pair_idx; (Number 2.0)])]))) in (let () = ignore ((names := sx_append_b !names vname; Nil)) in (let () = ignore ((val_exprs := sx_append_b !val_exprs val_expr; Nil)) in (env_bind local (sx_to_string vname) Nil))))) Nil (sx_to_list (prim_call "range" [(Number 0.0); (prim_call "/" [(len (bindings)); (Number 2.0)])]))))) in (let () = ignore ((let values = (List (List.map (fun e -> (trampoline ((eval_expr (e) (local))))) (sx_to_list !val_exprs))) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [!names; values])); Nil)) in (List.iter (fun val' -> ignore ((if sx_truthy ((is_lambda (val'))) then (List.iter (fun n -> ignore ((env_bind (lambda_closure (val')) (sx_to_string n) (env_get (local) (n))))) (sx_to_list !names); Nil) else Nil))) (sx_to_list values); Nil)))) in (let () = ignore ((List.iter (fun e -> ignore ((trampoline ((eval_expr (e) (local)))))) (sx_to_list (prim_call "slice" [body; (Number 0.0); (prim_call "dec" [(len (body))])])); Nil)) in (make_thunk ((last (body))) (local))))))

(* step-sf-letrec *)
and step_sf_letrec args env kont =
  (let thk = (sf_letrec (args) (env)) in (make_cek_state ((thunk_expr (thk))) ((thunk_env (thk))) (kont)))

(* sf-dynamic-wind *)
and sf_dynamic_wind args env =
  (let before = (trampoline ((eval_expr ((first (args))) (env)))) in let body = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in let after = (trampoline ((eval_expr ((nth (args) ((Number 2.0)))) (env)))) in (dynamic_wind_call (before) (body) (after) (env)))

(* sf-scope *)
and sf_scope args env =
  (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let rest = (prim_call "slice" [args; (Number 1.0)]) in let val' = ref (Nil) in let body_exprs = ref (Nil) in (let () = ignore ((if sx_truthy ((let _and = (prim_call ">=" [(len (rest)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (rest)))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((first (rest)))); (String "value")])))) then (let () = ignore ((val' := (trampoline ((eval_expr ((nth (rest) ((Number 1.0)))) (env)))); Nil)) in (body_exprs := (prim_call "slice" [rest; (Number 2.0)]); Nil)) else (body_exprs := rest; Nil))) in (let () = ignore ((scope_push (name) (!val'))) in (let result' = ref (Nil) in (let () = ignore ((List.iter (fun e -> ignore ((result' := (trampoline ((eval_expr (e) (env)))); Nil))) (sx_to_list !body_exprs); Nil)) in (let () = ignore ((scope_pop (name))) in !result'))))))

(* sf-provide *)
and sf_provide args env =
  (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let val' = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in let body_exprs = (prim_call "slice" [args; (Number 2.0)]) in let result' = ref (Nil) in (let () = ignore ((scope_push (name) (val'))) in (let () = ignore ((List.iter (fun e -> ignore ((result' := (trampoline ((eval_expr (e) (env)))); Nil))) (sx_to_list body_exprs); Nil)) in (let () = ignore ((scope_pop (name))) in !result'))))

(* expand-macro *)
and expand_macro mac raw_args env =
  (let body = (macro_body (mac)) in (if sx_truthy ((let _and = (symbol_p (body)) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (body)); (String "__syntax-rules-body__")]))) then (let closure = (macro_closure (mac)) in (syntax_rules_expand ((env_get (closure) ((String "__sr-literals")))) ((env_get (closure) ((String "__sr-rules")))) (raw_args))) else (let local = (env_merge ((macro_closure (mac))) (env)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (if sx_truthy ((prim_call "<" [(nth (pair) ((Number 1.0))); (len (raw_args))])) then (nth (raw_args) ((nth (pair) ((Number 1.0))))) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [p; i])) (sx_to_list (macro_params (mac)))))); Nil)) in (let () = ignore ((if sx_truthy ((macro_rest_param (mac))) then (env_bind local (sx_to_string (macro_rest_param (mac))) (prim_call "slice" [raw_args; (len ((macro_params (mac))))])) else Nil)) in (trampoline ((eval_expr ((macro_body (mac))) (local)))))))))

(* cek-step-loop *)
and cek_step_loop state =
  (if sx_truthy ((let _or = (cek_terminal_p (state)) in if sx_truthy _or then _or else (cek_suspended_p (state)))) then state else (cek_step_loop ((cek_step (state)))))

(* cek-run *)
and cek_run state =
  (let rec run s =
    let final = cek_step_loop s in
    if sx_truthy (cek_suspended_p final) then begin
      let request = cek_io_request final in
      let op = match request with Dict d -> (match Hashtbl.find_opt d "op" with Some (String s) -> s | _ -> "") | _ -> "" in
      if op = "import" then
        let lib_spec = match request with Dict d -> (match Hashtbl.find_opt d "library" with Some v -> v | _ -> Nil) | _ -> Nil in
        let key = library_name_key lib_spec in
        let resolved = sx_truthy (library_loaded_p key) ||
          (match !_import_hook with Some hook -> hook lib_spec | None -> false) in
        if resolved then run (cek_resume final Nil)
        else raise (Eval_error "IO suspension in non-IO context")
      else raise (Eval_error "IO suspension in non-IO context")
    end else cek_value final
  in run state)

(* cek-resume *)
and cek_resume suspended_state result' =
  (cek_step_loop ((make_cek_value (result') ((cek_env (suspended_state))) ((cek_kont (suspended_state))))))

(* cek-step *)
and cek_step state =
  (if sx_truthy ((prim_call "=" [(cek_phase (state)); (String "eval")])) then (step_eval (state)) else (step_continue (state)))

(* step-eval *)
and step_eval state =
  (let expr = (cek_control (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (let _match_val = (type_of (expr)) in (if _match_val = (String "number") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "string") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "boolean") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "nil") then (make_cek_value (Nil) (env) (kont)) else (if _match_val = (String "symbol") then (let name = (symbol_name (expr)) in (let val' = (if sx_truthy ((env_has (env) (name))) then (env_get (env) (name)) else (if sx_truthy ((is_primitive (name))) then (get_primitive (name)) else (if sx_truthy ((prim_call "=" [name; (String "true")])) then (Bool true) else (if sx_truthy ((prim_call "=" [name; (String "false")])) then (Bool false) else (if sx_truthy ((prim_call "=" [name; (String "nil")])) then Nil else (match !_symbol_resolve_hook with Some hook -> (match hook (value_to_str name) with Some v -> v | None -> raise (Eval_error ("Undefined symbol: " ^ value_to_str name))) | None -> raise (Eval_error ("Undefined symbol: " ^ value_to_str name)))))))) in (let () = ignore ((if sx_truthy ((let _and = (is_nil (val')) in if not (sx_truthy _and) then _and else (prim_call "starts-with?" [name; (String "~")]))) then (debug_log ((String "Component not found:")) (name)) else Nil)) in (make_cek_value (val') (env) (kont))))) else (if _match_val = (String "keyword") then (make_cek_value ((keyword_name (expr))) (env) (kont)) else (if _match_val = (String "dict") then (let ks = (prim_call "keys" [expr]) in (if sx_truthy ((empty_p (ks))) then (make_cek_value ((Dict (Hashtbl.create 0))) (env) (kont)) else (let first_key = (first (ks)) in let remaining_entries = ref ((List [])) in (let () = ignore ((List.iter (fun k -> ignore ((remaining_entries := sx_append_b !remaining_entries (List [k; (get (expr) (k))]); Nil))) (sx_to_list (rest (ks))); Nil)) in (make_cek_state ((get (expr) (first_key))) (env) ((kont_push ((make_dict_frame (!remaining_entries) ((List [(List [first_key])])) (env))) (kont)))))))) else (if _match_val = (String "list") then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (step_eval_list (expr) (env) (kont))) else (make_cek_value (expr) (env) (kont))))))))))))

(* step-sf-raise *)
and step_sf_raise args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont))))

(* step-sf-guard *)
and step_sf_guard args env kont =
  (let var_clauses = (first (args)) in let body = (rest (args)) in let var = (first (var_clauses)) in let clauses = (rest (var_clauses)) in let sentinel = (make_symbol ((String "__guard-reraise__"))) in (step_eval_list ((List [(Symbol "let"); (List [(List [(Symbol "__guard-result"); (cons ((Symbol "call/cc")) ((List [(cons ((Symbol "fn")) ((cons ((List [(Symbol "__guard-k")])) ((List [(cons ((Symbol "handler-bind")) ((cons ((List [(List [(cons ((Symbol "fn")) ((cons ((List [(Symbol "_")])) ((List [(Bool true)]))))); (cons ((Symbol "fn")) ((cons ((List [var])) ((List [(List [(Symbol "__guard-k"); (cons ((Symbol "cond")) ((prim_call "append" [clauses; (List [(List [(Symbol "else"); (List [(Symbol "list"); (List [(Symbol "quote"); sentinel]); var])])])])))])])))))])])) ((List [(List [(Symbol "__guard-k"); (cons ((Symbol "begin")) (body))])])))))])))))])))])]); (List [(Symbol "if"); (List [(Symbol "and"); (List [(Symbol "list?"); (Symbol "__guard-result")]); (List [(Symbol "="); (List [(Symbol "len"); (Symbol "__guard-result")]); (Number 2.0)]); (List [(Symbol "="); (List [(Symbol "first"); (Symbol "__guard-result")]); (List [(Symbol "quote"); sentinel])])]); (List [(Symbol "raise"); (List [(Symbol "nth"); (Symbol "__guard-result"); (Number 1.0)])]); (Symbol "__guard-result")])])) (env) (kont)))

(* step-sf-callcc *)
and step_sf_callcc args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_callcc_frame (env))) (kont))))

(* step-sf-case *)
and step_sf_case args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_case_frame (Nil) ((rest (args))) (env))) (kont))))

(* step-sf-let-match *)
and step_sf_let_match args env kont =
  (let pattern = (first (args)) in let expr = (nth (args) ((Number 1.0))) in let body = (rest ((rest (args)))) in (step_sf_match ((List [expr; (List [pattern; (cons ((Symbol "begin")) (body))])])) (env) (kont)))

(* step-eval-list *)
and step_eval_list expr env kont =
  (let head = (first (expr)) in let args = (rest (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((let _or = (prim_call "=" [(type_of (head)); (String "symbol")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [(type_of (head)); (String "lambda")]) in if sx_truthy _or then _or else (prim_call "=" [(type_of (head)); (String "list")])))))))) then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (make_cek_state ((first (expr))) (env) ((kont_push ((make_map_frame (Nil) ((rest (expr))) ((List [])) (env))) (kont))))) else (if sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])) then (let name = (symbol_name (head)) in (let _match_val = name in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (step_sf_if (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (step_sf_when (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (step_sf_cond (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (step_sf_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (step_sf_and (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (step_sf_or (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let*")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "lambda")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "fn")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defcomp")])) then (make_cek_value ((sf_defcomp (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defisland")])) then (make_cek_value ((sf_defisland (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defmacro")])) then (make_cek_value ((sf_defmacro (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defio")])) then (make_cek_value ((sf_defio (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "io")])) then (step_sf_io (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "do")])) then (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (args)))))) in if not (sx_truthy _and) then _and else (let _and = (list_p ((first (args)))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p ((first (args)))))))) in if not (sx_truthy _and) then _and else (list_p ((first ((first (args)))))))))) then (let bindings = (first (args)) in let test_clause = (nth (args) ((Number 1.0))) in let body = (rest ((rest (args)))) in let vars = (List (List.map (fun b -> (first (b))) (sx_to_list bindings))) in let inits = (List (List.map (fun b -> (nth (b) ((Number 1.0)))) (sx_to_list bindings))) in let steps = (List (List.map (fun b -> (if sx_truthy ((prim_call ">" [(len (b)); (Number 2.0)])) then (nth (b) ((Number 2.0))) else (first (b)))) (sx_to_list bindings))) in let test = (first (test_clause)) in let result' = (rest (test_clause)) in (step_eval_list ((cons ((Symbol "let")) ((cons ((Symbol "__do-loop")) ((cons ((List (List.map (fun b -> (List [(first (b)); (nth (b) ((Number 1.0)))])) (sx_to_list bindings)))) ((List [(cons ((Symbol "if")) ((cons (test) ((cons ((if sx_truthy ((empty_p (result'))) then Nil else (cons ((Symbol "begin")) (result')))) ((List [(cons ((Symbol "begin")) ((prim_call "append" [body; (List [(cons ((Symbol "__do-loop")) (steps))])])))])))))))])))))))) (env) (kont))) else (step_sf_begin (args) (env) (kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "guard")])) then (step_sf_guard (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "quote")])) then (make_cek_value ((if sx_truthy ((empty_p (args))) then Nil else (first (args)))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "quasiquote")])) then (make_cek_value ((qq_expand ((first (args))) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "->")])) then (step_sf_thread_first (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "->>")])) then (step_sf_thread_last (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "|>")])) then (step_sf_thread_last (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "as->")])) then (step_sf_thread_as (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "set!")])) then (step_sf_set_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "letrec")])) then (step_sf_letrec (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (step_sf_reset (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "shift")])) then (step_sf_shift (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (step_sf_deref (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (step_sf_scope (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (step_sf_provide (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler-bind")])) then (step_sf_handler_bind (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart-case")])) then (step_sf_restart_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-condition")])) then (step_sf_signal (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "invoke-restart")])) then (step_sf_invoke_restart (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "match")])) then (step_sf_match (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let-match")])) then (step_sf_let_match (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "dynamic-wind")])) then (make_cek_value ((sf_dynamic_wind (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (step_ho_map (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (step_ho_map_indexed (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (step_ho_filter (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (step_ho_reduce (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (step_ho_some (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "every?")])) then (step_ho_every (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (step_ho_for_each (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise")])) then (step_sf_raise (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-continuable")])) then (make_cek_state ((first (args))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool true)))) (kont)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "call/cc")])) then (step_sf_callcc (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "call-with-current-continuation")])) then (step_sf_callcc (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (step_sf_perform (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-library")])) then (step_sf_define_library (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (step_sf_import (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-record-type")])) then (make_cek_value ((sf_define_record_type (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-protocol")])) then (make_cek_value ((sf_define_protocol (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "implement")])) then (make_cek_value ((sf_implement (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "parameterize")])) then (step_sf_parameterize (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "syntax-rules")])) then (make_cek_value ((sf_syntax_rules (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-syntax")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((prim_call "has-key?" [custom_special_forms; name])) then (make_cek_value ((cek_call ((get (custom_special_forms) (name))) (List [args; env]))) (env) (kont)) else (if sx_truthy ((let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_macro ((env_get (env) (name)))))) then (let mac = (env_get (env) (name)) in (make_cek_state ((expand_macro (mac) (args) (env))) (env) (kont))) else (if sx_truthy ((let _and = render_check in if not (sx_truthy _and) then _and else (cek_call (render_check) (List [expr; env])))) then (make_cek_value ((cek_call (render_fn) (List [expr; env]))) (env) (kont)) else (step_eval_call (head) (args) (env) (kont))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) else (step_eval_call (head) (args) (env) (kont)))))

(* step-sf-parameterize *)
and step_sf_parameterize args env kont =
  (let bindings = (first (args)) in let body = (rest (args)) in (if sx_truthy ((let _or = (is_nil (bindings)) in if sx_truthy _or then _or else (empty_p (bindings)))) then (step_sf_begin (body) (env) (kont)) else (let first_pair = (first (bindings)) in (make_cek_state ((first (first_pair))) (env) ((kont_push ((make_parameterize_frame (bindings) (Nil) ((List [])) (body) (env))) (kont)))))))

(* syntax-rules-match *)
and syntax_rules_match pattern form literals =
  (if sx_truthy ((let _and = (symbol_p (pattern)) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (pattern)); (String "_")]))) then (Dict (Hashtbl.create 0)) else (if sx_truthy ((let _and = (symbol_p (pattern)) in if not (sx_truthy _and) then _and else (prim_call "contains?" [literals; (symbol_name (pattern))]))) then (if sx_truthy ((let _and = (symbol_p (form)) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (pattern)); (symbol_name (form))]))) then (Dict (Hashtbl.create 0)) else Nil) else (if sx_truthy ((symbol_p (pattern))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((sx_dict_set_b d (symbol_name (pattern)) form)) in d)) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (empty_p (pattern)))) then (if sx_truthy ((let _and = (list_p (form)) in if not (sx_truthy _and) then _and else (empty_p (form)))) then (Dict (Hashtbl.create 0)) else Nil) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (list_p (form)))) then (syntax_rules_match_list (pattern) ((Number 0.0)) (form) ((Number 0.0)) (literals)) else (if sx_truthy ((prim_call "=" [pattern; form])) then (Dict (Hashtbl.create 0)) else Nil))))))

(* syntax-rules-match-list *)
and syntax_rules_match_list pattern pi form fi literals =
  (let plen = (len (pattern)) in let flen = (len (form)) in (if sx_truthy ((let _and = (prim_call ">=" [pi; plen]) in if not (sx_truthy _and) then _and else (prim_call ">=" [fi; flen]))) then (Dict (Hashtbl.create 0)) else (if sx_truthy ((prim_call ">=" [pi; plen])) then Nil else (if sx_truthy ((let _and = (prim_call "<" [(prim_call "+" [pi; (Number 1.0)]); plen]) in if not (sx_truthy _and) then _and else (let _and = (symbol_p ((nth (pattern) ((prim_call "+" [pi; (Number 1.0)]))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (pattern) ((prim_call "+" [pi; (Number 1.0)]))))); (String "...")])))) then (let sub_pat = (nth (pattern) (pi)) in let rest_pat_count = (prim_call "-" [plen; (prim_call "+" [pi; (Number 2.0)])]) in let available = (prim_call "-" [flen; fi]) in let n_ellipsis = (prim_call "-" [(prim_call "-" [flen; fi]); (prim_call "-" [plen; (prim_call "+" [pi; (Number 2.0)])])]) in (if sx_truthy ((prim_call "<" [n_ellipsis; (Number 0.0)])) then Nil else (let ellipsis_forms = (prim_call "slice" [form; fi; (prim_call "+" [fi; n_ellipsis])]) in let sub_bindings = (List (List.map (fun f -> (syntax_rules_match (sub_pat) (f) (literals))) (sx_to_list (prim_call "slice" [form; fi; (prim_call "+" [fi; n_ellipsis])])))) in (if sx_truthy ((prim_call "contains?" [sub_bindings; Nil])) then Nil else (let rest_result = (syntax_rules_match_list (pattern) ((prim_call "+" [pi; (Number 2.0)])) (form) ((prim_call "+" [fi; n_ellipsis])) (literals)) in (if sx_truthy ((is_nil (rest_result))) then Nil else (let merged = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun b -> ignore ((List.iter (fun key -> ignore ((let existing = (dict_get (merged) (key)) in (if sx_truthy ((is_nil (existing))) then (sx_dict_set_b merged key (List [(get (b) (key))])) else (sx_dict_set_b merged key (prim_call "append" [existing; (List [(get (b) (key))])])))))) (sx_to_list (prim_call "keys" [b])); Nil))) (sx_to_list sub_bindings); Nil)) in (let () = ignore ((List.iter (fun key -> ignore ((sx_dict_set_b merged key (get (rest_result) (key))))) (sx_to_list (prim_call "keys" [rest_result])); Nil)) in merged))))))))) else (if sx_truthy ((prim_call ">=" [fi; flen])) then Nil else (let sub_result = (syntax_rules_match ((nth (pattern) (pi))) ((nth (form) (fi))) (literals)) in (if sx_truthy ((is_nil (sub_result))) then Nil else (let rest_result = (syntax_rules_match_list (pattern) ((prim_call "+" [pi; (Number 1.0)])) (form) ((prim_call "+" [fi; (Number 1.0)])) (literals)) in (if sx_truthy ((is_nil (rest_result))) then Nil else (let () = ignore ((List.iter (fun key -> ignore ((sx_dict_set_b rest_result key (get (sub_result) (key))))) (sx_to_list (prim_call "keys" [sub_result])); Nil)) in rest_result))))))))))

(* syntax-rules-find-var *)
and syntax_rules_find_var template bindings =
  (if sx_truthy ((let _and = (symbol_p (template)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "has-key?" [bindings; (symbol_name (template))]) in if not (sx_truthy _and) then _and else (list_p ((get (bindings) ((symbol_name (template))))))))) then (symbol_name (template)) else (if sx_truthy ((list_p (template))) then (List.fold_left (fun found t -> (if sx_truthy ((is_nil (found))) then (syntax_rules_find_var (t) (bindings)) else found)) Nil (sx_to_list template)) else Nil))

(* syntax-rules-find-all-vars *)
and syntax_rules_find_all_vars template bindings =
  (if sx_truthy ((let _and = (symbol_p (template)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "has-key?" [bindings; (symbol_name (template))]) in if not (sx_truthy _and) then _and else (list_p ((get (bindings) ((symbol_name (template))))))))) then (List [(symbol_name (template))]) else (if sx_truthy ((list_p (template))) then (List.fold_left (fun acc t -> (prim_call "append" [acc; (syntax_rules_find_all_vars (t) (bindings))])) (List []) (sx_to_list template)) else (List [])))

(* syntax-rules-instantiate *)
and syntax_rules_instantiate template bindings =
  (if sx_truthy ((let _and = (symbol_p (template)) in if not (sx_truthy _and) then _and else (prim_call "has-key?" [bindings; (symbol_name (template))]))) then (get (bindings) ((symbol_name (template)))) else (if sx_truthy ((Bool (not (sx_truthy ((list_p (template))))))) then template else (if sx_truthy ((empty_p (template))) then template else (syntax_rules_instantiate_list (template) ((Number 0.0)) (bindings)))))

(* syntax-rules-instantiate-list *)
and syntax_rules_instantiate_list template i bindings =
  (if sx_truthy ((prim_call ">=" [i; (len (template))])) then (List []) else (let elem = (nth (template) (i)) in let has_ellipsis = (let _and = (prim_call "<" [(prim_call "+" [i; (Number 1.0)]); (len (template))]) in if not (sx_truthy _and) then _and else (let _and = (symbol_p ((nth (template) ((prim_call "+" [i; (Number 1.0)]))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (template) ((prim_call "+" [i; (Number 1.0)]))))); (String "...")]))) in (if sx_truthy (has_ellipsis) then (let all_vars = (syntax_rules_find_all_vars (elem) (bindings)) in (if sx_truthy ((empty_p (all_vars))) then (syntax_rules_instantiate_list (template) ((prim_call "+" [i; (Number 2.0)])) (bindings)) else (let count = (len ((get (bindings) ((first (all_vars)))))) in let expanded = (List (List.map (fun idx -> (let b = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun key -> ignore ((sx_dict_set_b b key (get (bindings) (key))))) (sx_to_list (prim_call "keys" [bindings])); Nil)) in (let () = ignore ((List.iter (fun var_name -> ignore ((sx_dict_set_b b var_name (nth ((get (bindings) (var_name))) (idx))))) (sx_to_list all_vars); Nil)) in (syntax_rules_instantiate (elem) (b)))))) (sx_to_list (prim_call "range" [count])))) in let rest_result = (syntax_rules_instantiate_list (template) ((prim_call "+" [i; (Number 2.0)])) (bindings)) in (prim_call "append" [expanded; rest_result])))) else (cons ((syntax_rules_instantiate (elem) (bindings))) ((syntax_rules_instantiate_list (template) ((prim_call "+" [i; (Number 1.0)])) (bindings)))))))

(* syntax-rules-expand *)
and syntax_rules_expand literals rules form =
  (let full_form = (cons ((make_symbol ((String "_")))) (form)) in (syntax_rules_try_rules (literals) (rules) (full_form)))

(* syntax-rules-try-rules *)
and syntax_rules_try_rules literals rules full_form =
  (if sx_truthy ((empty_p (rules))) then (raise (Eval_error (value_to_str (String (sx_str [(String "syntax-rules: no pattern matched for "); (inspect (full_form))]))))) else (let rule = (first (rules)) in let pattern = (first (rule)) in let template = (nth (rule) ((Number 1.0))) in (let bindings = (syntax_rules_match (pattern) (full_form) (literals)) in (if sx_truthy ((Bool (not (sx_truthy ((is_nil (bindings))))))) then (syntax_rules_instantiate (template) (bindings)) else (syntax_rules_try_rules (literals) ((rest (rules))) (full_form))))))

(* sf-syntax-rules *)
and sf_syntax_rules args env =
  (let literals = (if sx_truthy ((list_p ((first (args))))) then (List (List.map (fun s -> (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s])))) (sx_to_list (first (args))))) else (List [])) in let rules = (rest (args)) in (let closure = (env_extend (env)) in (let () = ignore ((env_bind closure (sx_to_string (String "__sr-literals")) literals)) in (let () = ignore ((env_bind closure (sx_to_string (String "__sr-rules")) rules)) in (make_macro ((List [])) ((String "__sr-form")) ((Symbol "__syntax-rules-body__")) (closure) ((String "syntax-rules")))))))

(* step-sf-define-library *)
and step_sf_define_library args env kont =
  (let lib_spec = (first (args)) in let decls = (rest (args)) in (let lib_env = (env_extend (env)) in let exports = ref ((List [])) in let body_forms = ref ((List [])) in (let () = ignore ((List.iter (fun decl -> ignore ((if sx_truthy ((let _and = (list_p (decl)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (decl)))))) in if not (sx_truthy _and) then _and else (symbol_p ((first (decl))))))) then (let kind = (symbol_name ((first (decl)))) in (if sx_truthy ((prim_call "=" [kind; (String "export")])) then (exports := (prim_call "append" [!exports; (List (List.map (fun s -> (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s])))) (sx_to_list (rest (decl)))))]); Nil) else (if sx_truthy ((prim_call "=" [kind; (String "begin")])) then (body_forms := (prim_call "append" [!body_forms; (rest (decl))]); Nil) else Nil))) else Nil))) (sx_to_list decls); Nil)) in (let () = ignore ((List.iter (fun form -> ignore ((eval_expr (form) (lib_env)))) (sx_to_list !body_forms); Nil)) in (let export_dict = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun name -> ignore ((if sx_truthy ((env_has (lib_env) (name))) then (sx_dict_set_b export_dict name (env_get (lib_env) (name))) else Nil))) (sx_to_list !exports); Nil)) in (let () = ignore ((register_library (lib_spec) (export_dict))) in (make_cek_value (Nil) (env) (kont)))))))))

(* bind-import-set *)
and bind_import_set import_set env =
  (let head = (if sx_truthy ((let _and = (list_p (import_set)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (import_set)))))) in if not (sx_truthy _and) then _and else (symbol_p ((first (import_set))))))) then (symbol_name ((first (import_set)))) else Nil) in (let lib_spec = (if sx_truthy ((let _or = (prim_call "=" [head; (String "only")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [head; (String "except")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [head; (String "prefix")]) in if sx_truthy _or then _or else (prim_call "=" [head; (String "rename")]))))) then (nth (import_set) ((Number 1.0))) else import_set) in (let exports = (library_exports (lib_spec)) in (if sx_truthy ((prim_call "=" [head; (String "only")])) then (List.iter (fun s -> ignore ((let id = (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s]))) in (if sx_truthy ((prim_call "has-key?" [exports; id])) then (env_bind env (sx_to_string id) (get (exports) (id))) else Nil)))) (sx_to_list (rest ((rest (import_set))))); Nil) else (if sx_truthy ((prim_call "=" [head; (String "prefix")])) then (let pfx = (String (sx_str [(nth (import_set) ((Number 2.0)))])) in (List.iter (fun key -> ignore ((env_bind env (sx_to_string (String (sx_str [pfx; key]))) (get (exports) (key))))) (sx_to_list (prim_call "keys" [exports])); Nil)) else (List.iter (fun key -> ignore ((env_bind env (sx_to_string key) (get (exports) (key))))) (sx_to_list (prim_call "keys" [exports])); Nil))))))

(* step-sf-import *)
and step_sf_import args env kont =
  (if sx_truthy ((empty_p (args))) then (make_cek_value (Nil) (env) (kont)) else (let import_set = (first (args)) in let rest_sets = (rest (args)) in (let lib_spec = (let head = (if sx_truthy ((let _and = (list_p (import_set)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (import_set)))))) in if not (sx_truthy _and) then _and else (symbol_p ((first (import_set))))))) then (symbol_name ((first (import_set)))) else Nil) in (if sx_truthy ((let _or = (prim_call "=" [head; (String "only")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [head; (String "except")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [head; (String "prefix")]) in if sx_truthy _or then _or else (prim_call "=" [head; (String "rename")]))))) then (nth (import_set) ((Number 1.0))) else import_set)) in (if sx_truthy ((library_loaded_p (lib_spec))) then (let () = ignore ((bind_import_set (import_set) (env))) in (if sx_truthy ((empty_p (rest_sets))) then (make_cek_value (Nil) (env) (kont)) else (step_sf_import (rest_sets) (env) (kont)))) else (make_cek_suspended ((let _d = Hashtbl.create 2 in Hashtbl.replace _d "library" lib_spec; Hashtbl.replace _d "op" (String "import"); Dict _d)) (env) ((kont_push ((make_import_frame (import_set) (rest_sets) (env))) (kont))))))))

(* step-sf-perform *)
and step_sf_perform args env kont =
  (if sx_truthy ((empty_p (args))) then (raise (Eval_error (value_to_str (String "perform requires an IO request argument")))) else (make_cek_state ((first (args))) (env) ((kont_push ((make_perform_frame (env))) (kont)))))


(* sf-define-record-type *)
and sf_define_record_type args env =
  (let type_sym = (first (args)) in let ctor_spec = (nth (args) ((Number 1.0))) in let pred_sym = (nth (args) ((Number 2.0))) in let field_specs = (prim_call "slice" [args; (Number 3.0)]) in (let raw_name = (symbol_name (type_sym)) in (let type_name = (if sx_truthy ((let _and = (prim_call "starts-with?" [raw_name; (String "<")]) in if not (sx_truthy _and) then _and else (prim_call "ends-with?" [raw_name; (String ">")]))) then (prim_call "slice" [raw_name; (Number 1.0); (prim_call "-" [(len (raw_name)); (Number 1.0)])]) else raw_name) in let ctor_name = (symbol_name ((first (ctor_spec)))) in let ctor_params = (List (List.map (fun s -> (symbol_name (s))) (sx_to_list (rest (ctor_spec))))) in let pred_name = (symbol_name (pred_sym)) in let field_names = (List (List.map (fun fs -> (symbol_name ((first (fs))))) (sx_to_list field_specs))) in (let rtd_uid = (make_rtd (type_name) (field_names) (ctor_params)) in (let () = ignore ((env_bind env (sx_to_string ctor_name) (make_record_constructor (rtd_uid)))) in (let () = ignore ((env_bind env (sx_to_string pred_name) (make_record_predicate (rtd_uid)))) in (let () = ignore ((for_each_indexed ((NativeFn ("\206\187", fun _args -> match _args with [idx; fs] -> (fun idx fs -> (let accessor_name = (symbol_name ((nth (fs) ((Number 1.0))))) in (let () = ignore ((env_bind env (sx_to_string accessor_name) (make_record_accessor (idx)))) in (if sx_truthy ((prim_call ">=" [(len (fs)); (Number 3.0)])) then (let mutator_name = (symbol_name ((nth (fs) ((Number 2.0))))) in (env_bind env (sx_to_string mutator_name) (make_record_mutator (idx)))) else Nil)))) idx fs | _ -> Nil))) (field_specs))) in Nil)))))))

(* sf-define-protocol *)
and sf_define_protocol args env =
  (let proto_name = (symbol_name ((first (args)))) in let method_specs = (rest (args)) in (let () = ignore ((let () = ignore ((env_bind env (sx_to_string (String "*protocol-registry*")) _protocol_registry_)) in (env_bind env (sx_to_string (String "satisfies?")) (NativeFn ("\206\187", fun _args -> match _args with [pname; val'] -> (fun pname val' -> (satisfies_p (pname) (val'))) pname val' | _ -> Nil))))) in (let () = ignore ((sx_dict_set_b _protocol_registry_ proto_name (let _d = Hashtbl.create 3 in Hashtbl.replace _d "impls" (Dict (Hashtbl.create 0)); Hashtbl.replace _d "methods" (List (List.map (fun spec -> (let _d = Hashtbl.create 2 in Hashtbl.replace _d "arity" (len (spec)); Hashtbl.replace _d "name" (symbol_name ((first (spec)))); Dict _d)) (sx_to_list method_specs))); Hashtbl.replace _d "name" proto_name; Dict _d))) in (let () = ignore ((List.iter (fun spec -> ignore ((let method_name = (symbol_name ((first (spec)))) in let params = (rest (spec)) in let pname = proto_name in (let self_sym = (first (params)) in let lookup_expr = (List [(Symbol "get"); (List [(Symbol "get"); (List [(Symbol "get"); (List [(Symbol "get"); (Symbol "*protocol-registry*"); pname]); (String "impls")]); (List [(Symbol "type-of"); self_sym])]); method_name]) in (env_bind env (sx_to_string method_name) (eval_expr ((List [(Symbol "fn"); params; (List [(Symbol "let"); (List [(List [(Symbol "_impl"); lookup_expr])]); (List [(Symbol "if"); (List [(Symbol "nil?"); (Symbol "_impl")]); (List [(Symbol "error"); (String (sx_str [pname; (String "."); method_name; (String ": not implemented for this type")]))]); (cons ((Symbol "_impl")) (params))])])])) (env))))))) (sx_to_list method_specs); Nil)) in Nil))))

(* sf-implement *)
and sf_implement args env =
  (let proto_name = (symbol_name ((first (args)))) in let raw_type_name = (symbol_name ((nth (args) ((Number 1.0))))) in let type_name = (prim_call "slice" [raw_type_name; (Number 1.0); (prim_call "-" [(len (raw_type_name)); (Number 1.0)])]) in let method_defs = (rest ((rest (args)))) in (let proto = (get (_protocol_registry_) (proto_name)) in (if sx_truthy ((is_nil (proto))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown protocol: "); proto_name]))))) else (let impls = (get (proto) ((String "impls"))) in let type_impls = (let _or = (get (impls) (type_name)) in if sx_truthy _or then _or else (Dict (Hashtbl.create 0))) in (let () = ignore ((List.iter (fun method_def -> ignore ((let mname = (symbol_name ((first (method_def)))) in let proto_method = (first ((List (List.filter (fun m -> sx_truthy ((prim_call "=" [(get (m) ((String "name"))); mname]))) (sx_to_list (get (proto) ((String "methods")))))))) in (if sx_truthy ((is_nil (proto_method))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown method "); mname; (String " in protocol "); proto_name]))))) else (let arity = (get (proto_method) ((String "arity"))) in let params = (prim_call "slice" [method_def; (Number 1.0); arity]) in let body = (if sx_truthy ((prim_call "=" [(len (method_def)); (prim_call "+" [arity; (Number 1.0)])])) then (nth (method_def) (arity)) else (cons ((Symbol "begin")) ((prim_call "slice" [method_def; arity])))) in (sx_dict_set_b type_impls mname (eval_expr ((List [(Symbol "fn"); params; body])) (env)))))))) (sx_to_list method_defs); Nil)) in (let () = ignore ((sx_dict_set_b impls type_name type_impls)) in Nil))))))

(* satisfies? *)
and satisfies_p proto_name value =
  (if sx_truthy ((Bool (not (sx_truthy ((record_p (value))))))) then (Bool false) else (let proto = (get (_protocol_registry_) ((if sx_truthy ((symbol_p (proto_name))) then (symbol_name (proto_name)) else proto_name))) in (if sx_truthy ((is_nil (proto))) then (Bool false) else (Bool (not (sx_truthy ((is_nil ((get ((get (proto) ((String "impls")))) ((type_of (value)))))))))))))

(* check-match-exhaustiveness *)
and check_match_exhaustiveness clauses =
  (let warnings = ref ((List [])) in let patterns = (List (List.map (fun c -> (first (c))) (sx_to_list clauses))) in let has_wildcard = (Bool (List.exists (fun p -> sx_truthy ((let _and = (symbol_p (p)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [p; (Bool true)]))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((prim_call "=" [p; (Bool false)]))))))))) (sx_to_list patterns))) in let has_else = (Bool (List.exists (fun p -> sx_truthy ((prim_call "=" [p; (String "else")]))) (sx_to_list patterns))) in let has_true = (Bool (List.exists (fun p -> sx_truthy ((prim_call "=" [p; (Bool true)]))) (sx_to_list patterns))) in let has_false = (Bool (List.exists (fun p -> sx_truthy ((prim_call "=" [p; (Bool false)]))) (sx_to_list patterns))) in (let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy (has_wildcard)))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (has_else)))))) then (warnings := (prim_call "append" [!warnings; (List [(String "match may be non-exhaustive (no wildcard or :else pattern)")])]); Nil) else Nil)) in (let () = ignore ((if sx_truthy ((let _and = (let _or = has_true in if sx_truthy _or then _or else has_false) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((let _and = has_true in if not (sx_truthy _and) then _and else has_false))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy (has_wildcard)))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (has_else)))))))) then (warnings := (prim_call "append" [!warnings; (List [(if sx_truthy (has_true) then (String "match on boolean missing false case") else (String "match on boolean missing true case"))])]); Nil) else Nil)) in !warnings)))

(* match-find-clause *)
and match_find_clause val' clauses env =
  (if sx_truthy ((empty_p (clauses))) then Nil else (let clause = (first (clauses)) in let pattern = (first (clause)) in let body = (nth (clause) ((Number 1.0))) in let local = (env_extend (env)) in (if sx_truthy ((match_pattern (pattern) (val') (local))) then (List [local; body]) else (match_find_clause (val') ((rest (clauses))) (env)))))

(* match-pattern *)
and match_pattern pattern value env =
  (if sx_truthy ((prim_call "=" [pattern; (Symbol "_")])) then (Bool true) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (pattern)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "?")])))) then (let pred = (eval_expr ((nth (pattern) ((Number 1.0)))) (env)) in (cek_call (pred) ((List [value])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (pattern)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "quote")])))) then (prim_call "=" [value; (nth (pattern) ((Number 1.0)))]) else (if sx_truthy ((symbol_p (pattern))) then (let () = ignore ((env_bind env (sx_to_string (symbol_name (pattern))) value)) in (Bool true)) else (if sx_truthy ((let _and = (dict_p (pattern)) in if not (sx_truthy _and) then _and else (dict_p (value)))) then (Bool (List.for_all (fun k -> sx_truthy ((match_pattern ((get (pattern) (k))) ((get (value) (k))) (env)))) (sx_to_list (prim_call "keys" [pattern])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (list_p (value)) in if not (sx_truthy _and) then _and else (prim_call "contains?" [pattern; (Symbol "&rest")])))) then (let rest_idx = (prim_call "index-of" [pattern; (Symbol "&rest")]) in (let _and = (prim_call ">=" [(len (value)); rest_idx]) in if not (sx_truthy _and) then _and else (let _and = (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list (prim_call "zip" [(prim_call "slice" [pattern; (Number 0.0); rest_idx]); (prim_call "slice" [value; (Number 0.0); rest_idx])])))) in if not (sx_truthy _and) then _and else (let rest_name = (nth (pattern) ((prim_call "+" [rest_idx; (Number 1.0)]))) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (rest_name))) (prim_call "slice" [value; rest_idx]))) in (Bool true)))))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (list_p (value)))) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(len (pattern)); (len (value))])))))) then (Bool false) else (let pairs = (prim_call "zip" [pattern; value]) in (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list pairs))))) else (prim_call "=" [pattern; value]))))))))

(* step-sf-match *)
and step_sf_match args env kont =
  (let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (raise (Eval_error (value_to_str (String (sx_str [(String "match: no clause matched "); (inspect (val'))]))))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont)))))

(* step-sf-handler-bind *)
and step_sf_handler_bind args env kont =
  (let handler_specs = (first (args)) in let body = (rest (args)) in let handlers = (List (List.map (fun spec -> (List [(trampoline ((eval_expr ((first (spec))) (env)))); (trampoline ((eval_expr ((nth (spec) ((Number 1.0)))) (env))))])) (sx_to_list handler_specs))) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (env) (kont)) else (make_cek_state ((first (body))) (env) ((kont_push ((make_handler_frame (handlers) ((rest (body))) (env))) (kont))))))

(* step-sf-restart-case *)
and step_sf_restart_case args env kont =
  (let body = (first (args)) in let restart_specs = (rest (args)) in let restarts = (List (List.map (fun spec -> (List [(if sx_truthy ((symbol_p ((first (spec))))) then (symbol_name ((first (spec)))) else (first (spec))); (nth (spec) ((Number 1.0))); (nth (spec) ((Number 2.0)))])) (sx_to_list restart_specs))) in (make_cek_state (body) (env) ((kont_push ((make_restart_frame (restarts) ((List [])) (env))) (kont)))))

(* step-sf-signal *)
and step_sf_signal args env kont =
  (let condition = (trampoline ((eval_expr ((first (args))) (env)))) in let handler_fn = (kont_find_handler (kont) (condition)) in (if sx_truthy ((is_nil (handler_fn))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Unhandled condition: "); (inspect (condition))]))))) else (continue_with_call (handler_fn) ((List [condition])) (env) ((List [condition])) ((kont_push ((make_signal_return_frame (env) (kont))) (kont))))))

(* step-sf-invoke-restart *)
and step_sf_invoke_restart args env kont =
  (let restart_name = (let rn = (if sx_truthy ((symbol_p ((first (args))))) then (symbol_name ((first (args)))) else (trampoline ((eval_expr ((first (args))) (env))))) in (if sx_truthy ((symbol_p (rn))) then (symbol_name (rn)) else rn)) in let restart_arg = (if sx_truthy ((prim_call ">=" [(len (args)); (Number 2.0)])) then (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) else Nil) in let found = (kont_find_restart (kont) (restart_name)) in (if sx_truthy ((is_nil (found))) then (raise (Eval_error (value_to_str (String (sx_str [(String "No restart named: "); (inspect (restart_name))]))))) else (let entry = (first (found)) in let restart_frame = (nth (found) ((Number 1.0))) in let rest_kont = (nth (found) ((Number 2.0))) in (let params = (nth (entry) ((Number 1.0))) in let body = (nth (entry) ((Number 2.0))) in let restart_env = (env_extend ((get (restart_frame) ((String "env"))))) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((empty_p (params))))))) then (env_bind restart_env (sx_to_string (first (params))) restart_arg) else Nil)) in (make_cek_state (body) (restart_env) (rest_kont)))))))

(* step-sf-if *)
and step_sf_if args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_if_frame ((nth (args) ((Number 1.0)))) ((if sx_truthy ((prim_call ">" [(len (args)); (Number 2.0)])) then (nth (args) ((Number 2.0))) else Nil)) (env))) (kont))))

(* step-sf-when *)
and step_sf_when args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_when_frame ((rest (args))) (env))) (kont))))

(* step-sf-begin *)
and step_sf_begin args env kont =
  (if sx_truthy ((empty_p (args))) then (make_cek_value (Nil) (env) (kont)) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (make_cek_state ((first (args))) (env) (kont)) else (make_cek_state ((first (args))) (env) ((kont_push ((make_begin_frame ((rest (args))) (env))) (kont))))))

(* step-sf-let *)
and step_sf_let args env kont =
  let pairs = ref Nil in (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (make_cek_value ((sf_named_let (args) (env))) (env) (kont)) else (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in (if sx_truthy ((empty_p (bindings))) then (step_sf_begin (body) (local) (kont)) else (let first_binding = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (first (bindings)) else (List [(first (bindings)); (nth (bindings) ((Number 1.0)))])) in let rest_bindings = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (rest (bindings)) else (let pairs = ref ((List [])) in (let () = ignore ((List.fold_left (fun _acc i -> (pairs := sx_append_b !pairs (List [(nth (bindings) ((prim_call "*" [i; (Number 2.0)]))); (nth (bindings) ((prim_call "inc" [(prim_call "*" [i; (Number 2.0)])])))]); Nil)) Nil (sx_to_list (prim_call "range" [(Number 1.0); (prim_call "/" [(len (bindings)); (Number 2.0)])])))) in !pairs))) in (let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (first_binding)))); (String "symbol")])) then (symbol_name ((first (first_binding)))) else (first (first_binding))) in (make_cek_state ((nth (first_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) (rest_bindings) (body) (local))) (kont)))))))))

(* step-sf-define *)
and step_sf_define args env kont =
  (let name_sym = (first (args)) in let has_effects = (let _and = (prim_call ">=" [(len (args)); (Number 4.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (args) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (args) ((Number 1.0))))); (String "effects")]))) in let val_idx = (if sx_truthy ((let _and = (prim_call ">=" [(len (args)); (Number 4.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (args) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (args) ((Number 1.0))))); (String "effects")])))) then (Number 3.0) else (Number 1.0)) in let effect_list = (if sx_truthy ((let _and = (prim_call ">=" [(len (args)); (Number 4.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (args) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (args) ((Number 1.0))))); (String "effects")])))) then (nth (args) ((Number 2.0))) else Nil) in (make_cek_state ((nth (args) (val_idx))) (env) ((kont_push ((make_define_frame ((symbol_name (name_sym))) (env) (has_effects) (effect_list))) (kont)))))

(* step-sf-set! *)
and step_sf_set_b args env kont =
  (make_cek_state ((nth (args) ((Number 1.0)))) (env) ((kont_push ((make_set_frame ((symbol_name ((first (args))))) (env))) (kont))))

(* step-sf-and *)
and step_sf_and args env kont =
  (if sx_truthy ((empty_p (args))) then (make_cek_value ((Bool true)) (env) (kont)) else (make_cek_state ((first (args))) (env) ((kont_push ((make_and_frame ((rest (args))) (env))) (kont)))))

(* step-sf-or *)
and step_sf_or args env kont =
  (if sx_truthy ((empty_p (args))) then (make_cek_value ((Bool false)) (env) (kont)) else (make_cek_state ((first (args))) (env) ((kont_push ((make_or_frame ((rest (args))) (env))) (kont)))))

(* step-sf-cond *)
and step_sf_cond args env kont =
  (let scheme_p = (cond_scheme_p (args)) in (if sx_truthy (scheme_p) then (if sx_truthy ((empty_p (args))) then (make_cek_value (Nil) (env) (kont)) else (let clause = (first (args)) in let test = (first (clause)) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state ((nth (clause) ((Number 1.0)))) (env) (kont)) else (make_cek_state (test) (env) ((kont_push ((make_cond_frame (args) (env) ((Bool true)))) (kont))))))) else (if sx_truthy ((prim_call "<" [(len (args)); (Number 2.0)])) then (make_cek_value (Nil) (env) (kont)) else (let test = (first (args)) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state ((nth (args) ((Number 1.0)))) (env) (kont)) else (make_cek_state (test) (env) ((kont_push ((make_cond_frame (args) (env) ((Bool false)))) (kont)))))))))

(* step-sf-thread-first *)
and step_sf_thread_first args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_thread_frame ((rest (args))) (env) ((String "first")) (Nil))) (kont))))

(* step-sf-thread-last *)
and step_sf_thread_last args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_thread_frame ((rest (args))) (env) ((String "last")) (Nil))) (kont))))

(* step-sf-thread-as *)
and step_sf_thread_as args env kont =
  (let init = (first (args)) in let name = (nth (args) ((Number 1.0))) in let forms = (rest ((rest (args)))) in (make_cek_state (init) (env) ((kont_push ((make_thread_frame (forms) (env) ((String "as")) (name))) (kont)))))

(* step-sf-lambda *)
and step_sf_lambda args env kont =
  (make_cek_value ((sf_lambda (args) (env))) (env) (kont))

(* step-sf-scope *)
and step_sf_scope args env kont =
  (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let rest_args = (prim_call "slice" [args; (Number 1.0)]) in let val' = ref (Nil) in let body = ref (Nil) in (let () = ignore ((if sx_truthy ((let _and = (prim_call ">=" [(len (rest_args)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (rest_args)))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((first (rest_args)))); (String "value")])))) then (let () = ignore ((val' := (trampoline ((eval_expr ((nth (rest_args) ((Number 1.0)))) (env)))); Nil)) in (body := (prim_call "slice" [rest_args; (Number 2.0)]); Nil)) else (body := rest_args; Nil))) in (if sx_truthy ((empty_p (!body))) then (make_cek_value (Nil) (env) (kont)) else (make_cek_state ((first (!body))) (env) ((kont_push ((make_scope_acc_frame (name) (!val') ((rest (!body))) (env))) (kont)))))))

(* step-sf-provide *)
and step_sf_provide args env kont =
  (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let val' = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in let body = (prim_call "slice" [args; (Number 2.0)]) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (env) (kont)) else (make_cek_state ((first (body))) (env) ((kont_push ((make_provide_frame (name) (val') ((rest (body))) (env))) (kont))))))

(* step-sf-context *)
and step_sf_context args env kont =
  (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let default_val = (if sx_truthy ((prim_call ">=" [(len (args)); (Number 2.0)])) then (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) else Nil) in let frame = (kont_find_provide (kont) (name)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (if sx_truthy ((env_has (env) ((String "context")))) then (sx_apply (env_get (env) ((String "context"))) (List [name; default_val])) else default_val))) (env) (kont)))

(* step-sf-emit *)
and step_sf_emit args env kont =
  (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let val' = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in let frame = (kont_find_scope_acc (kont) (name)) in (if sx_truthy (frame) then (let () = ignore ((sx_dict_set_b frame (String "emitted") (prim_call "append" [(get (frame) ((String "emitted"))); (List [val'])]))) in (make_cek_value (Nil) (env) (kont))) else (let () = ignore ((if sx_truthy ((env_has (env) ((String "scope-emit!")))) then (sx_apply (env_get (env) ((String "scope-emit!"))) (List [name; val'])) else Nil)) in (make_cek_value (Nil) (env) (kont)))))

(* step-sf-emitted *)
and step_sf_emitted args env kont =
  (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let frame = (kont_find_scope_acc (kont) (name)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "emitted"))) else (if sx_truthy ((env_has (env) ((String "emitted")))) then (sx_apply (env_get (env) ((String "emitted"))) (List [name])) else (List [])))) (env) (kont)))

(* step-sf-reset *)
and step_sf_reset args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_reset_frame (env))) (kont))))

(* step-sf-shift *)
and step_sf_shift args env kont =
  (let k_name = (symbol_name ((first (args)))) in let body = (nth (args) ((Number 1.0))) in let captured_result = (kont_capture_to_reset (kont)) in let captured = (first (captured_result)) in let rest_kont = (nth (captured_result) ((Number 1.0))) in (let k = (make_cek_continuation (captured) (rest_kont)) in (let shift_env = (env_extend (env)) in (let () = ignore ((env_bind shift_env (sx_to_string k_name) k)) in (make_cek_state (body) (shift_env) (rest_kont))))))

(* step-sf-deref *)
and step_sf_deref args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_deref_frame (env))) (kont))))

(* cek-call *)
and cek_call f args =
  (let a = (if sx_truthy ((is_nil (args))) then (List []) else args) in (if sx_truthy ((is_nil (f))) then Nil else (if sx_truthy ((let _or = (is_lambda (f)) in if sx_truthy _or then _or else (is_callable (f)))) then (cek_run ((continue_with_call (f) (a) ((make_env ())) (a) ((List []))))) else Nil)))

(* reactive-shift-deref *)
and reactive_shift_deref sig' env kont =
  (let scan_result = (kont_capture_to_reactive_reset (kont)) in let captured_frames = (first (scan_result)) in let reset_frame = (nth (scan_result) ((Number 1.0))) in let remaining_kont = (nth (scan_result) ((Number 2.0))) in let update_fn = (get (reset_frame) ((String "update-fn"))) in (let sub_disposers = ref ((List [])) in (let subscriber = (NativeFn ("\206\187", fun _args -> (fun () -> let sub_disposers = ref Nil in (let () = ignore ((List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil)) in (let () = ignore ((sub_disposers := (List []); Nil)) in (let new_reset = (make_reactive_reset_frame (env) (update_fn) ((Bool false))) in let new_kont = (prim_call "concat" [captured_frames; (List [new_reset]); remaining_kont]) in (with_island_scope ((NativeFn ("\206\187", fun _args -> match _args with [d] -> (fun d -> let sub_disposers = ref Nil in (sub_disposers := sx_append_b !sub_disposers d; Nil)) d | _ -> Nil))) ((NativeFn ("\206\187", fun _args -> (fun () -> (cek_run ((make_cek_value ((signal_value (sig'))) (env) (new_kont))))) ())))))))) ())) in (let () = ignore ((signal_add_sub_b (sig') (subscriber))) in (let () = ignore ((register_in_scope ((NativeFn ("\206\187", fun _args -> (fun () -> (let () = ignore ((signal_remove_sub_b (sig') (subscriber))) in (List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil))) ()))))) in (let initial_kont = (prim_call "concat" [captured_frames; (List [reset_frame]); remaining_kont]) in (make_cek_value ((signal_value (sig'))) (env) (initial_kont))))))))

(* step-eval-call *)
and step_eval_call head args env kont =
  (let hname = (if sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])) then (symbol_name (head)) else Nil) in (make_cek_state (head) (env) ((kont_push ((make_arg_frame (Nil) ((List [])) (args) (env) (args) (hname))) (kont)))))

(* ho-form-name? *)
and ho_form_name_p name =
  (let _or = (prim_call "=" [name; (String "map")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "map-indexed")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "filter")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "reduce")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "some")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "every?")]) in if sx_truthy _or then _or else (prim_call "=" [name; (String "for-each")])))))))

(* ho-fn? *)
and ho_fn_p v =
  (let _or = (is_callable (v)) in if sx_truthy _or then _or else (is_lambda (v)))

(* ho-swap-args *)
and ho_swap_args ho_type evaled =
  (if sx_truthy ((prim_call "=" [ho_type; (String "reduce")])) then (let a = (first (evaled)) in let b = (nth (evaled) ((Number 1.0))) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((ho_fn_p (a)))))) in if not (sx_truthy _and) then _and else (ho_fn_p (b)))) then (List [b; (nth (evaled) ((Number 2.0))); a]) else evaled)) else (let a = (first (evaled)) in let b = (nth (evaled) ((Number 1.0))) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((ho_fn_p (a)))))) in if not (sx_truthy _and) then _and else (ho_fn_p (b)))) then (List [b; a]) else evaled)))

(* ho-setup-dispatch *)
and ho_setup_dispatch ho_type evaled env kont =
  (let ordered = (ho_swap_args (ho_type) (evaled)) in (let f = (first (ordered)) in (let _match_val = ho_type in (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (if sx_truthy ((prim_call ">" [(len (ordered)); (Number 2.0)])) then (let colls = (rest (ordered)) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list colls)))) then (make_cek_value ((List [])) (env) (kont)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list colls))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list colls))) in (continue_with_call (f) (heads) (env) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) ((List [])) (env))) (kont))))))) else (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_map_frame (f) ((rest (coll))) ((List [])) (env))) (kont))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(Number 0.0); (first (coll))])) (env) ((List [])) ((kont_push ((make_map_indexed_frame (f) ((rest (coll))) ((List [])) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (coll))) ((List [])) ((first (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let init = (nth (ordered) ((Number 1.0))) in let coll = (nth (ordered) ((Number 2.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (init) (env) (kont)) else (continue_with_call (f) ((List [init; (first (coll))])) (env) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool false)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_some_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool true)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_every_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (Nil) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (coll))) (env))) (kont)))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown HO type: "); ho_type])))))))))))))))

(* step-ho-map *)
and step_ho_map args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "map")) ((rest (args))) ((List [])) (env))) (kont))))

(* step-ho-map-indexed *)
and step_ho_map_indexed args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "map-indexed")) ((rest (args))) ((List [])) (env))) (kont))))

(* step-ho-filter *)
and step_ho_filter args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "filter")) ((rest (args))) ((List [])) (env))) (kont))))

(* step-ho-reduce *)
and step_ho_reduce args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "reduce")) ((rest (args))) ((List [])) (env))) (kont))))

(* step-ho-some *)
and step_ho_some args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "some")) ((rest (args))) ((List [])) (env))) (kont))))

(* step-ho-every *)
and step_ho_every args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "every")) ((rest (args))) ((List [])) (env))) (kont))))

(* step-ho-for-each *)
and step_ho_for_each args env kont =
  (make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "for-each")) ((rest (args))) ((List [])) (env))) (kont))))

(* step-continue *)
and step_continue state =
  let _last_error_kont_ = ref Nil in (let value = (cek_value (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (if sx_truthy ((kont_empty_p (kont))) then state else (let frame = (kont_top (kont)) in let rest_k = (kont_pop (kont)) in let ft = (frame_type (frame)) in (let _match_val = ft in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (make_cek_state ((get (frame) ((String "then")))) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((is_nil ((get (frame) ((String "else")))))) then (make_cek_value (Nil) (env) (rest_k)) else (make_cek_state ((get (frame) ((String "else")))) ((get (frame) ((String "env")))) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (make_cek_state ((first (body))) (fenv) (rest_k)) else (make_cek_state ((first (body))) (fenv) ((kont_push ((make_begin_frame ((rest (body))) (fenv))) (rest_k))))))) else (make_cek_value (Nil) (env) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then (make_cek_state ((first (remaining))) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_begin_frame ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let body = (get (frame) ((String "body"))) in let local = (get (frame) ((String "env"))) in (let () = ignore ((env_bind local (sx_to_string name) value)) in (if sx_truthy ((empty_p (remaining))) then (step_sf_begin (body) (local) (rest_k)) else (let next_binding = (first (remaining)) in let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (next_binding)))); (String "symbol")])) then (symbol_name ((first (next_binding)))) else (first (next_binding))) in (make_cek_state ((nth (next_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) ((rest (remaining))) (body) (local))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let has_effects = (get (frame) ((String "has-effects"))) in let effect_list = (get (frame) ((String "effect-list"))) in (let () = ignore ((if sx_truthy ((let _and = (is_lambda (value)) in if not (sx_truthy _and) then _and else (is_nil ((lambda_name (value)))))) then (set_lambda_name value (sx_to_string name)) else Nil)) in (let () = ignore ((env_bind fenv (sx_to_string name) value)) in (let () = ignore ((if sx_truthy (has_effects) then (let effect_names = (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else e)) (sx_to_list effect_list))) in let effect_anns = (if sx_truthy ((env_has (fenv) ((String "*effect-annotations*")))) then (env_get (fenv) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns name effect_names)) in (env_bind fenv (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (make_cek_value (value) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((env_set fenv (sx_to_string name) value)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_and_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (if sx_truthy (value) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_or_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let scheme_p = (get (frame) ((String "scheme"))) in (if sx_truthy (scheme_p) then (if sx_truthy (value) then (let clause = (first (remaining)) in (if sx_truthy ((let _and = (prim_call ">" [(len (clause)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (clause) ((Number 1.0))))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (clause) ((Number 1.0))))); (String "=>")])))) then (make_cek_state ((nth (clause) ((Number 2.0)))) (fenv) ((kont_push ((make_cond_arrow_frame (value) (fenv))) (rest_k)))) else (make_cek_state ((nth (clause) ((Number 1.0)))) (fenv) (rest_k)))) else (let next_clauses = (rest (remaining)) in (if sx_truthy ((empty_p (next_clauses))) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_clause = (first (next_clauses)) in let next_test = (first (next_clause)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next_clause) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next_clauses) (fenv) ((Bool true)))) (rest_k))))))))) else (if sx_truthy (value) then (make_cek_state ((nth (remaining) ((Number 1.0)))) (fenv) (rest_k)) else (let next = (prim_call "slice" [remaining; (Number 2.0); (len (remaining))]) in (if sx_truthy ((prim_call "<" [(len (next)); (Number 2.0)])) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_test = (first (next)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next) (fenv) ((Bool false)))) (rest_k))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (let match_val = (get (frame) ((String "match-val"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (match_val))) then (sf_case_step_loop (value) (remaining) (fenv) (rest_k)) else (sf_case_step_loop (match_val) (remaining) (fenv) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "thread")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let mode = (get (frame) ((String "extra"))) in let bind_name = (get (frame) ((String "name"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (let form = (first (remaining)) in let rest_forms = (rest (remaining)) in let new_kont = (if sx_truthy ((empty_p ((rest (remaining))))) then rest_k else (kont_push ((make_thread_frame ((rest (remaining))) (fenv) (mode) (bind_name))) (rest_k))) in (if sx_truthy ((prim_call "=" [mode; (String "as")])) then (let new_env = (env_extend (fenv)) in (let () = ignore ((env_bind new_env (sx_to_string (symbol_name (bind_name))) value)) in (make_cek_state (form) (new_env) (new_kont)))) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (form)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (form)))))) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (form)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (ho_form_name_p ((symbol_name ((first (form)))))))))) then (make_cek_state ((cons ((first (form))) ((cons ((List [(Symbol "quote"); value])) ((rest (form))))))) (fenv) (new_kont)) else (if sx_truthy ((prim_call "=" [mode; (String "last")])) then (let result' = (thread_insert_arg_last (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv) (mode) (bind_name))) (rest_k)))))) else (let result' = (thread_insert_arg (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv) (mode) (bind_name))) (rest_k)))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "arg")])) then (let f = (get (frame) ((String "f"))) in let evaled = (get (frame) ((String "evaled"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let raw_args = (get (frame) ((String "raw-args"))) in let hname = (get (frame) ((String "head-name"))) in (if sx_truthy ((is_nil (f))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) ((List []))) else Nil)) in (if sx_truthy ((empty_p (remaining))) then (continue_with_call (value) ((List [])) (fenv) (raw_args) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (value) ((List [])) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))) else (let new_evaled = (prim_call "append" [evaled; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) (new_evaled)) else Nil)) in (continue_with_call (f) (new_evaled) (fenv) (raw_args) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (f) (new_evaled) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "dict")])) then (let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let fenv = (get (frame) ((String "env"))) in (let last_result = (last (results)) in let completed = (prim_call "append" [(prim_call "slice" [results; (Number 0.0); (prim_call "dec" [(len (results))])]); (List [(List [(first (last_result)); value])])]) in (if sx_truthy ((empty_p (remaining))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun pair -> ignore ((sx_dict_set_b d (first (pair)) (nth (pair) ((Number 1.0)))))) (sx_to_list completed); Nil)) in (make_cek_value (d) (fenv) (rest_k)))) else (let next_entry = (first (remaining)) in (make_cek_state ((nth (next_entry) ((Number 1.0)))) (fenv) ((kont_push ((make_dict_frame ((rest (remaining))) ((prim_call "append" [completed; (List [(List [(first (next_entry))])])])) (fenv))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "ho-setup")])) then (let ho_type = (get (frame) ((String "ho-type"))) in let remaining = (get (frame) ((String "remaining"))) in let evaled = (prim_call "append" [(get (frame) ((String "evaled"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (ho_setup_dispatch (ho_type) (evaled) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_ho_setup_frame (ho_type) ((rest (remaining))) (evaled) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (let val' = value in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy ((is_signal (val'))))))) then (make_cek_value (val') (fenv) (rest_k)) else (if sx_truthy ((has_reactive_reset_frame_p (rest_k))) then (reactive_shift_deref (val') (fenv) (rest_k)) else (let () = ignore ((let ctx = (sx_context ((String "sx-reactive")) (Nil)) in (if sx_truthy (ctx) then (let dep_list = ref ((get (ctx) ((String "deps")))) in let notify_fn = (get (ctx) ((String "notify"))) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!dep_list; val'])))))) then (let () = ignore ((dep_list := sx_append_b !dep_list val'; Nil)) in (signal_add_sub_b (val') (notify_fn))) else Nil)) else Nil))) in (make_cek_value ((signal_value (val'))) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reactive-reset")])) then (let update_fn = (get (frame) ((String "update-fn"))) in let first_p = (get (frame) ((String "first-render"))) in (let () = ignore ((if sx_truthy ((let _and = update_fn in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (first_p)))))) then (cek_call (update_fn) ((List [value]))) else Nil)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop (name))) in (make_cek_value (value) (fenv) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_scope_frame (name) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope-acc")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((let new_frame = (make_scope_acc_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "emitted") (get (frame) ((String "emitted"))))) in new_frame))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let indexed = (get (frame) ((String "indexed"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (prim_call "append" [results; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let call_args = (if sx_truthy (indexed) then (List [(len (new_results)); (first (remaining))]) else (List [(first (remaining))])) in let next_frame = (if sx_truthy (indexed) then (make_map_indexed_frame (f) ((rest (remaining))) (new_results) (fenv)) else (make_map_frame (f) ((rest (remaining))) (new_results) (fenv))) in (continue_with_call (f) (call_args) (fenv) ((List [])) ((kont_push (next_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let current_item = (get (frame) ((String "current-item"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (if sx_truthy (value) then (prim_call "append" [results; (List [current_item])]) else results) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (remaining))) (new_results) ((first (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (continue_with_call (f) ((List [value; (first (remaining))])) (fenv) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (Nil) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy (value) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_some_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool true)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_every_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_handler_frame ((get (frame) ((String "f")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-return")])) then (let saved_kont = (get (frame) ((String "saved-kont"))) in (make_cek_value (value) ((get (frame) ((String "env")))) (saved_kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "comp-trace")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond-arrow")])) then (let test_value = (get (frame) ((String "match-val"))) in let fenv = (get (frame) ((String "env"))) in (continue_with_call (value) ((List [test_value])) (fenv) ((List [test_value])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-eval")])) then (let condition = value in let fenv = (get (frame) ((String "env"))) in let continuable_p = (get (frame) ((String "scheme"))) in let handler_fn = (kont_find_handler (rest_k) (condition)) in (if sx_truthy ((is_nil (handler_fn))) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String (sx_str [(String "Unhandled exception: "); (inspect (condition))]))))) else (continue_with_call (handler_fn) ((List [condition])) (fenv) ((List [condition])) ((if sx_truthy (continuable_p) then (kont_push ((make_signal_return_frame (fenv) (rest_k))) (rest_k)) else (kont_push ((make_raise_guard_frame (fenv) (rest_k))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-guard")])) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String "exception handler returned from non-continuable raise")))) else (if sx_truthy ((prim_call "=" [_match_val; (String "multi-map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let new_results = (prim_call "append" [(get (frame) ((String "results"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list remaining)))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list remaining))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list remaining))) in (continue_with_call (f) (heads) (fenv) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) (new_results) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "callcc")])) then (let k = (make_callcc_continuation (rest_k)) in (continue_with_call (value) ((List [k])) ((get (frame) ((String "env")))) ((List [k])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "vm-resume")])) then (let resume_fn = (get (frame) ((String "f"))) in (let result' = (sx_apply resume_fn (List [value])) in (if sx_truthy ((let _and = (dict_p (result')) in if not (sx_truthy _and) then _and else (get (result') ((String "__vm_suspended"))))) then (make_cek_suspended ((get (result') ((String "request")))) ((get (frame) ((String "env")))) ((kont_push ((make_vm_resume_frame ((get (result') ((String "resume")))) ((get (frame) ((String "env")))))) (rest_k)))) else (make_cek_value (result') ((get (frame) ((String "env")))) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (make_cek_suspended (value) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (let import_set = (get (frame) ((String "args"))) in let remaining_sets = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((bind_import_set (import_set) (fenv))) in (if sx_truthy ((empty_p (remaining_sets))) then (make_cek_value (Nil) (fenv) (rest_k)) else (step_sf_import (remaining_sets) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "parameterize")])) then (let remaining = (get (frame) ((String "remaining"))) in let current_param = (get (frame) ((String "f"))) in let results = (get (frame) ((String "results"))) in let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (current_param))) then (let param_obj = value in let val_expr = (nth ((first (remaining))) ((Number 1.0))) in (make_cek_state (val_expr) (fenv) ((kont_push ((make_parameterize_frame (remaining) (param_obj) (results) (body) (fenv))) (rest_k))))) else (let converted_val = value in let new_results = (prim_call "append" [results; (List [(List [(parameter_uid (current_param)); converted_val])])]) in let rest_bindings = (rest (remaining)) in (if sx_truthy ((empty_p (rest_bindings))) then (let body_expr = (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (first (body)) else (cons ((Symbol "begin")) (body))) in let provide_kont = (kont_push_provides (new_results) (fenv) (rest_k)) in (make_cek_state (body_expr) (fenv) (provide_kont))) else (make_cek_state ((first ((first (rest_bindings))))) (fenv) ((kont_push ((make_parameterize_frame (rest_bindings) (Nil) (new_results) (body) (fenv))) (rest_k)))))))) else (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown frame type: "); ft])))))))))))))))))))))))))))))))))))))))))))))))))

(* continue-with-call *)
and continue_with_call f args env raw_args kont =
  (if sx_truthy ((parameter_p (f))) then (let uid = (parameter_uid (f)) in let frame = (kont_find_provide (kont) (uid)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (parameter_default (f)))) (env) (kont))) else (if sx_truthy ((callcc_continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let captured = (callcc_continuation_data (f)) in (make_cek_value (arg) (env) (captured))) else (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (make_cek_value ((sx_apply f args)) (env) (kont)) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (let jit_result = (jit_try_call (f) (args)) in (if sx_truthy ((is_nil (jit_result))) then (make_cek_state ((lambda_body (f))) (local) (kont)) else (if sx_truthy ((let _and = (dict_p (jit_result)) in if not (sx_truthy _and) then _and else (get (jit_result) ((String "__vm_suspended"))))) then (make_cek_suspended ((get (jit_result) ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (jit_result) ((String "resume")))) (env))) (kont)))) else (make_cek_value (jit_result) (local) (kont))))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_push ((make_comp_trace_frame ((component_name (f))) ((component_file (f))))) (kont))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))])))))))))))

(* sf-case-step-loop *)
and sf_case_step_loop match_val clauses env kont =
  (if sx_truthy ((prim_call "<" [(len (clauses)); (Number 2.0)])) then (make_cek_value (Nil) (env) (kont)) else (let test = (first (clauses)) in let body = (nth (clauses) ((Number 1.0))) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state (body) (env) (kont)) else (let test_val = (trampoline ((eval_expr (test) (env)))) in (if sx_truthy ((prim_call "=" [match_val; test_val])) then (make_cek_state (body) (env) (kont)) else (sf_case_step_loop (match_val) ((prim_call "slice" [clauses; (Number 2.0)])) (env) (kont)))))))

(* eval-expr-cek *)
and eval_expr_cek expr env =
  (cek_run ((make_cek_state (expr) (env) ((List [])))))

(* trampoline-cek *)
and trampoline_cek val' =
  (if sx_truthy ((is_thunk (val'))) then (eval_expr_cek ((thunk_expr (val'))) ((thunk_env (val')))) else val')

(* eval-expr *)
and eval_expr expr env =
  (cek_run ((make_cek_state (expr) (env) ((List [])))))


(* Wire up trampoline to resolve thunks via the CEK machine *)
let () = trampoline_fn := (fun v ->
  match v with
  | Thunk (expr, env) -> eval_expr expr (Env env)
  | _ -> v)

(* Wire up the primitives trampoline so call_any in HO forms resolves Thunks *)
let () = Sx_primitives._sx_trampoline_fn := !trampoline_fn

(* Override recursive cek_run with iterative loop.
   On error, capture the kont from the last state for comp-trace. *)
let cek_run_iterative state =
  let s = ref state in
  (try
    while not (match cek_terminal_p !s with Bool true -> true | _ -> false)
       && not (match cek_suspended_p !s with Bool true -> true | _ -> false) do
      s := cek_step !s
    done;
    (match cek_suspended_p !s with
     | Bool true ->
       let request = cek_io_request !s in
       let op = match request with Dict d -> (match Hashtbl.find_opt d "op" with Some (String s) -> s | _ -> "") | _ -> "" in
       if op = "import" then begin
         let lib_spec = match request with Dict d -> (match Hashtbl.find_opt d "library" with Some v -> v | _ -> Nil) | _ -> Nil in
         let key = library_name_key lib_spec in
         let resolved = sx_truthy (library_loaded_p key) ||
           (match !_import_hook with Some hook -> hook lib_spec | None -> false) in
         if resolved then begin
           s := cek_resume !s Nil;
           (* Continue the step loop after resolving the import *)
           while not (match cek_terminal_p !s with Bool true -> true | _ -> false)
              && not (match cek_suspended_p !s with Bool true -> true | _ -> false) do
             s := cek_step !s
           done;
           (match cek_suspended_p !s with
            | Bool true -> raise (Eval_error "IO suspension in non-IO context")
            | _ -> cek_value !s)
         end else raise (Eval_error "IO suspension in non-IO context")
       end else raise (Eval_error "IO suspension in non-IO context")
     | _ -> cek_value !s)
  with Eval_error msg ->
    _last_error_kont_ref := cek_kont !s;
    raise (Eval_error msg))

(* Collect component trace from a kont value *)
let collect_comp_trace kont =
  let trace = ref [] in
  let k = ref kont in
  while (match !k with List (_::_) -> true | _ -> false) do
    (match !k with
     | List (frame :: rest) ->
       (match frame with
        | CekFrame f when f.cf_type = "comp-trace" ->
          let name = match f.cf_name with String s -> s | _ -> "?" in
          let file = match f.cf_env with String s -> s | Nil -> "" | _ -> "" in
          trace := (name, file) :: !trace
        | Dict d when (match Hashtbl.find_opt d "type" with Some (String "comp-trace") -> true | _ -> false) ->
          let name = match Hashtbl.find_opt d "name" with Some (String s) -> s | _ -> "?" in
          let file = match Hashtbl.find_opt d "file" with Some (String s) -> s | _ -> "" in
          trace := (name, file) :: !trace
        | _ -> ());
       k := List rest
     | _ -> k := List [])
  done;
  List.rev !trace

(* Format a comp-trace into a human-readable string *)
let format_comp_trace trace =
  match trace with
  | [] -> ""
  | entries ->
    let lines = List.mapi (fun i (name, file) ->
      let prefix = if i = 0 then "  in " else "  called from " in
      if file = "" then prefix ^ "~" ^ name
      else prefix ^ "~" ^ name ^ " (" ^ file ^ ")"
    ) entries in
    "
" ^ String.concat "
" lines

(* Enhance an error message with component trace *)
let enhance_error_with_trace msg =
  let trace = collect_comp_trace !_last_error_kont_ref in
  _last_error_kont_ref := Nil;
  msg ^ (format_comp_trace trace)