coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
8a08de26cd2ae461de2b91fbfb0aca12c3339be1
rose-ash/hosts/ocaml/lib/sx_ref.ml
giles 7d793ec76c Fix CSSX styling: trampoline wiring + scope-emit!/emitted for adapter-html.sx 
Root causes of missing CSSX classes in SSR:

1. _sx_trampoline_fn in sx_primitives.ml was never wired — call_any in
   HO forms (map/filter/for-each) returned unresolved Thunks, so callbacks
   like render-lambda-html's param binding never executed. Fixed in
   bootstrap.py FIXUPS: wire Sx_primitives._sx_trampoline_fn after eval_expr.

2. adapter-html.sx used (emit! ...) and (emitted ...) which are CEK special
   forms (walk kont for ScopeAccFrame), but scope-push!/scope-pop! use the
   hashtable. CEK frames and hashtable are two different scope systems.
   Fixed: adapter uses scope-emit!/scope-emitted (hashtable primitives).

3. env-* operations (env-has?, env-get, env-bind!, env-set!, env-extend,
   env-merge) only accepted Env type. adapter-html.sx passes Dict as env.
   Fixed: all env ops go through unwrap_env which handles Dict/Nil.

Also: fix merge conflict in sx/sx/geography/index.sx, remove duplicate
scope primitives from sx_primitives.ml (sx_server.ml registers them).

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-03-24 02:23:00 +00:00

532 lines
82 KiB
OCaml
Raw Blame History

(* 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 state for strict mode === *)
(* These are defined as top-level refs because the transpiler cannot handle
global set! mutation (it creates local refs that shadow the global). *)
let _strict_ref = ref (Bool false)
let _prim_param_types_ref = ref Nil
(* JIT call hook — cek_call checks this before CEK dispatch for named
lambdas. Registered by sx_server.ml after compiler loads. Tests
run with hook = None (pure CEK, no compilation dependency). *)
let jit_call_hook : (value -> value list -> value option) option ref = ref None
(* === 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 })
(* 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-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-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-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 =
(CekFrame { cf_type = "thread"; 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-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-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-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 })
(* 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-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
(* *strict* *)
and _strict_ = !_strict_ref
(* set-strict! *)
and set_strict_b val' =
_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 =
_prim_param_types_ref := types; Nil
(* value-matches-type? *)
and value_matches_type_p val' expected_type =
(if sx_truthy ((prim_call "=" [expected_type; (String "any")])) then (Bool true) else (if sx_truthy ((prim_call "=" [expected_type; (String "number")])) then (number_p (val')) else (if sx_truthy ((prim_call "=" [expected_type; (String "string")])) then (string_p (val')) else (if sx_truthy ((prim_call "=" [expected_type; (String "boolean")])) then (boolean_p (val')) else (if sx_truthy ((prim_call "=" [expected_type; (String "nil")])) then (is_nil (val')) else (if sx_truthy ((prim_call "=" [expected_type; (String "list")])) then (list_p (val')) else (if sx_truthy ((prim_call "=" [expected_type; (String "dict")])) then (dict_p (val')) else (if sx_truthy ((prim_call "=" [expected_type; (String "lambda")])) then (is_lambda (val')) else (if sx_truthy ((prim_call "=" [expected_type; (String "symbol")])) then (prim_call "=" [(type_of (val')); (String "symbol")]) else (if sx_truthy ((prim_call "=" [expected_type; (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)
(* 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 (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 (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 (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); 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 (prim_call "=" [(len (c)); (Number 2.0)])))) (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 (call_lambda (loop_fn) (init_vals) (env))))))))
(* 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 ((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 = (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 island = (make_island (comp_name) (params) (has_children) (body) (env)) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) island)) in island)))
(* 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 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-run *)
and cek_run state =
(if sx_truthy ((cek_terminal_p (state))) then (cek_value (state)) else (cek_run ((cek_step (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 (raise (Eval_error (value_to_str (String (sx_str [(String "Undefined symbol: "); 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-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 (if sx_truthy ((prim_call "=" [name; (String "if")])) then (step_sf_if (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "when")])) then (step_sf_when (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "cond")])) then (step_sf_cond (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "case")])) then (step_sf_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "and")])) then (step_sf_and (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "or")])) then (step_sf_or (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "let")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "let*")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "lambda")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "fn")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "define")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defcomp")])) then (make_cek_value ((sf_defcomp (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defisland")])) then (make_cek_value ((sf_defisland (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defmacro")])) then (make_cek_value ((sf_defmacro (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "begin")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "do")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (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 "=" [name; (String "quasiquote")])) then (make_cek_value ((qq_expand ((first (args))) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "->")])) then (step_sf_thread_first (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "set!")])) then (step_sf_set_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "letrec")])) then (step_sf_letrec (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "reset")])) then (step_sf_reset (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "shift")])) then (step_sf_shift (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "deref")])) then (step_sf_deref (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "scope")])) then (step_sf_scope (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "provide")])) then (step_sf_provide (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "dynamic-wind")])) then (make_cek_value ((sf_dynamic_wind (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "map")])) then (step_ho_map (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "map-indexed")])) then (step_ho_map_indexed (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "filter")])) then (step_ho_filter (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "reduce")])) then (step_ho_reduce (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "some")])) then (step_ho_some (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "every?")])) then (step_ho_every (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "for-each")])) then (step_ho_for_each (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-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-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-thread-first *)
and step_sf_thread_first args env kont =
(make_cek_state ((first (args))) (env) ((kont_push ((make_thread_frame ((rest (args))) (env))) (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 ((is_nil (frame))) then default_val else (get (frame) ((String "value"))))) (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 (let () = ignore ((if sx_truthy (frame) then (sx_dict_set_b frame (String "emitted") (prim_call "append" [(get (frame) ((String "emitted"))); (List [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 ((is_nil (frame))) then (List []) else (get (frame) ((String "emitted"))))) (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 = (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 ((fun d -> let sub_disposers = ref Nil in (sub_disposers := sx_append_b !sub_disposers d; Nil))) ((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 ((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 (if sx_truthy ((prim_call "=" [ho_type; (String "map")])) 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_map_frame (f) ((rest (coll))) ((List [])) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [ho_type; (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 "=" [ho_type; (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 "=" [ho_type; (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 "=" [ho_type; (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 "=" [ho_type; (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 "=" [ho_type; (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 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 (if sx_truthy ((prim_call "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 = (if sx_truthy ((prim_call "=" [(type_of (effect_list)); (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 effect_list))) else (List [(String (sx_str [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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 (make_cek_state ((nth ((first (remaining))) ((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)]) 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 "=" [ft; (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 "=" [ft; (String "thread")])) 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 (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))) (rest_k))) in (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 (let result' = (if sx_truthy ((prim_call "=" [(type_of (form)); (String "list")])) then (let f = (trampoline ((eval_expr ((first (form))) (fenv)))) in let rargs = (List (List.map (fun a -> (trampoline ((eval_expr (a) (fenv))))) (sx_to_list (rest (form))))) in let all_args = (cons (value) (rargs)) in (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_lambda (f)))))))) then (sx_apply f all_args) else (if sx_truthy ((is_lambda (f))) then (trampoline ((call_lambda (f) (all_args) (fenv)))) else (raise (Eval_error (value_to_str (String (sx_str [(String "-> form not callable: "); (inspect (f))])))))))) else (let f = (trampoline ((eval_expr (form) (fenv)))) in (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_lambda (f)))))))) then (cek_call (f) (List [value])) else (if sx_truthy ((is_lambda (f))) then (trampoline ((call_lambda (f) ((List [value])) (fenv)))) else (raise (Eval_error (value_to_str (String (sx_str [(String "-> form not callable: "); (inspect (f))]))))))))) 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))) (rest_k)))))))))) else (if sx_truthy ((prim_call "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (String "reset")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 "=" [ft; (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 (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 ((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 (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 (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 (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil)) in (match !jit_call_hook, f with | Some hook, Lambda l when l.l_name <> None -> let args_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in (match hook f args_list with Some result -> make_cek_value result local kont | None -> make_cek_state (lambda_body f) local kont) | _ -> make_cek_state ((lambda_body (f))) (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))))) 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 *)
let cek_run_iterative state =
let s = ref state in
while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do
s := cek_step !s
done;
cek_value !s
Reference in New Issue View Git Blame Copy Permalink