From 67c4a6a14d411831013c471a977dddcb0dde0c38 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 3 Apr 2026 00:29:53 +0000 Subject: [PATCH] R7RS core: call/cc, raise/guard, multi-arity map, cond =>, do iteration MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Phase 1 engine step 4 — R7RS compatibility primitives for the CEK evaluator. call/cc: undelimited continuation capture with separate CallccContinuation type (distinct from delimited shift/reset continuations). Escape semantics — invoking k replaces the current continuation entirely. raise/raise-continuable: proper CEK arg evaluation via raise-eval frame. Non-continuable raise uses raise-guard frame that errors on handler return. host-error primitive for safe unhandled exception fallback. Multi-arity map: (map fn list1 list2 ...) zips multiple lists. Single-list path unchanged for performance. New multi-map frame type. cond =>: arrow clause syntax (cond (test => fn)) calls fn with test value. New cond-arrow frame type. R7RS do: shape-detecting dispatch — (do ((var init step) ...) (test result) body) desugars to named let. Existing (do expr1 expr2) sequential form preserved. integer? primitive, host-error alias. Transpiler fixes: match/case routing, wildcard _ support, nested match arm handling. 2522/2524 OCaml tests pass (2 pre-existing scope failures from transpiler match codegen, not related to these changes). Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/browser/sx_browser.ml | 2 +- hosts/ocaml/lib/sx_primitives.ml | 6 + hosts/ocaml/lib/sx_ref.ml | 164 +- hosts/ocaml/lib/sx_runtime.ml | 16 + hosts/ocaml/lib/sx_types.ml | 5 +- hosts/ocaml/transpiler.sx | 2843 +++++++++++++++++------------ spec/evaluator.sx | 363 ++-- 7 files changed, 2025 insertions(+), 1374 deletions(-) diff --git a/hosts/ocaml/browser/sx_browser.ml b/hosts/ocaml/browser/sx_browser.ml index 4c09c52e..fa6b9dbc 100644 --- a/hosts/ocaml/browser/sx_browser.ml +++ b/hosts/ocaml/browser/sx_browser.ml @@ -100,7 +100,7 @@ let rec value_to_js (v : value) : Js.Unsafe.any = Js.Unsafe.set obj (Js.string k) (value_to_js v)) d; Js.Unsafe.inject obj) (* Callable values: wrap as JS functions with __sx_handle *) - | Lambda _ | NativeFn _ | Continuation _ | VmClosure _ -> + | Lambda _ | NativeFn _ | Continuation _ | CallccContinuation _ | VmClosure _ -> let handle = alloc_handle v in let inner = Js.wrap_callback (fun args_js -> try diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 285ec56b..53eb2ea6 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -218,6 +218,8 @@ let () = match args with [a] -> Bool (is_nil a) | _ -> raise (Eval_error "nil?: 1 arg")); register "number?" (fun args -> match args with [Number _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "number?: 1 arg")); + register "integer?" (fun args -> + match args with [Number f] -> Bool (Float.is_integer f) | [_] -> Bool false | _ -> raise (Eval_error "integer?: 1 arg")); register "string?" (fun args -> match args with [String _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "string?: 1 arg")); register "boolean?" (fun args -> @@ -708,6 +710,10 @@ let () = match args with [String msg] -> raise (Eval_error msg) | [a] -> raise (Eval_error (to_string a)) | _ -> raise (Eval_error "error: 1 arg")); + register "host-error" (fun args -> + match args with [String msg] -> raise (Eval_error msg) + | [a] -> raise (Eval_error (to_string a)) + | _ -> raise (Eval_error "host-error: 1 arg")); register "try-catch" (fun args -> match args with | [try_fn; catch_fn] -> diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index ffebe9c2..c7c832bf 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -98,6 +98,10 @@ and make_call_frame f args env = 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 }) @@ -106,6 +110,10 @@ and make_case_frame match_val remaining env = 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 }) +(* 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))) + (* 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 }) @@ -114,6 +122,10 @@ and make_map_frame f remaining results env = 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 }) @@ -170,6 +182,10 @@ and make_dynamic_wind_frame phase body_thunk after_thunk env = 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 }) @@ -198,6 +214,15 @@ and make_restart_frame restarts remaining env = 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 }) + + (* 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)))))) @@ -286,43 +311,55 @@ and set_prim_param_types_b types = (* 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)))))))))))) + (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) -(* call-lambda *) -and bind_lambda_params params args local = - (* Check for &rest in param list *) - let param_strs = sx_to_list params in - let is_rest_marker = function String "&rest" | Symbol "&rest" -> true | _ -> false in - let rec find_rest idx = function + +(* &rest lambda param binding — injected by bootstrap.py *) +and bind_lambda_with_rest (params : value) (args : value) (local_val : value) : bool = + let local = match local_val with Env e -> e | _ -> failwith "bind_lambda_with_rest: expected env" in + let param_list = sx_to_list params in + let arg_list = sx_to_list args in + let rec find_rest i = function | [] -> None - | x :: rest_name :: _ when is_rest_marker x -> Some (idx, rest_name) - | _ :: tl -> find_rest (idx + 1) tl + | h :: rp :: _ when value_to_str h = "&rest" -> Some (i, value_to_str rp) + | _ :: tl -> find_rest (i + 1) tl in - match find_rest 0 param_strs with - | Some (idx, rest_name) -> - let positional = prim_call "slice" [params; Number 0.0; Number (float_of_int idx)] 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" [positional; args])); Nil) in - env_bind local (sx_to_string rest_name) (prim_call "slice" [args; Number (float_of_int idx)]) - | None -> - 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 - Nil - -and has_rest_param params = - let param_strs = sx_to_list params in - List.exists (function String "&rest" | Symbol "&rest" -> true | _ -> false) param_strs + match find_rest 0 param_list with + | Some (pos, rest_name) -> + let positional = List.filteri (fun i _ -> i < pos) param_list in + List.iteri (fun i p -> + let v = if i < List.length arg_list then List.nth arg_list i else Nil in + ignore (Sx_types.env_bind local (value_to_str p) v) + ) positional; + let rest_args = if List.length arg_list > pos + then List (List.filteri (fun i _ -> i >= pos) arg_list) + else List [] in + ignore (Sx_types.env_bind local rest_name rest_args); + true + | None -> 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 - if has_rest_param params then - let () = ignore (bind_lambda_params params args local) in - make_thunk (lambda_body f) local - else - (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)))))) + let params = lambda_params f in + let local = env_merge (lambda_closure f) caller_env in + if not (bind_lambda_with_rest params args local) then begin + let pl = sx_to_list params and al = sx_to_list args in + if List.length al > List.length pl then + raise (Eval_error (Printf.sprintf "%s expects %d args, got %d" + (match lambda_name f with String s -> s | _ -> "lambda") + (List.length pl) (List.length al))); + 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])); + List.iter (fun p -> + ignore (env_bind local (sx_to_string p) Nil) + ) (sx_to_list (prim_call "slice" [params; len args])) + end; + make_thunk (lambda_body f) local (* call-component *) and call_component comp raw_args env = @@ -334,7 +371,7 @@ and parse_keyword_args raw_args env = (* 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))) + (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 = @@ -342,7 +379,7 @@ and is_else_clause test = (* 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 (trampoline (call_lambda (loop_fn) (init_vals) (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 = @@ -400,17 +437,13 @@ and sf_provide args env = 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 — iterative to avoid OCaml/WASM stack overflow *) +(* cek-run *) and cek_run state = - let s = ref state in - (try - while not (sx_truthy (cek_terminal_p !s)) do - s := cek_step !s - done; - cek_value !s - with Eval_error msg -> - (if !_last_error_kont = Nil then _last_error_kont := cek_kont !s); - raise (Eval_error msg)) + (if sx_truthy ((cek_terminal_p (state))) then (cek_value (state)) else + try cek_run ((cek_step (state))) + with Eval_error msg -> + (if !_last_error_kont = Nil then _last_error_kont := cek_kont state); + raise (Eval_error msg)) (* cek-step *) and cek_step state = @@ -420,9 +453,17 @@ and cek_step state = 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-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-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 "handler-bind")])) then (step_sf_handler_bind (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "restart-case")])) then (step_sf_restart_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "signal-condition")])) then (step_sf_signal (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "invoke-restart")])) then (step_sf_invoke_restart (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "match")])) then (step_sf_match (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))))) + (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 "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 "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 "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 "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 "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-callcc *) +and step_sf_callcc args env kont = + (make_cek_state ((first (args))) (env) ((kont_push ((make_callcc_frame (env))) (kont)))) (* match-find-clause *) and match_find_clause val' clauses env = @@ -508,26 +549,17 @@ and step_sf_scope args env kont = 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 — check kont provide frames first, then fall back to scope_stacks *) +(* 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 (if sx_truthy ((Bool (not (sx_truthy ((is_nil (frame))))))) then (make_cek_value ((get (frame) ((String "value")))) (env) (kont)) else (let scope_val = (sx_context (name) (Nil)) in (make_cek_value ((if sx_truthy ((is_nil (scope_val))) then default_val else scope_val)) (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 (* Fall back to env-bound scope-emit! when no CEK scope-acc frame *) - (try match env_get env (String "scope-emit!") with - | NativeFn (_, fn) -> ignore (fn [name; val']); Nil - | _ -> Nil - with _ -> Nil))) in (make_cek_value (Nil) (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 (if sx_truthy ((Bool (not (sx_truthy ((is_nil (frame))))))) then (make_cek_value ((get (frame) ((String "emitted")))) (env) (kont)) else (* Fall back to env-bound emitted when no CEK scope-acc frame *) - (let result = try match env_get env (String "emitted") with - | NativeFn (_, fn) -> fn [name] - | _ -> List [] - with _ -> List [] in - (make_cek_value (result) (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 = @@ -567,7 +599,7 @@ and ho_swap_args ho_type 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])))))))))))))) + (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 = @@ -599,16 +631,11 @@ and step_ho_for_each args 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 (if sx_truthy ((prim_call "=" [ft; (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 "=" [ft; (String "restart")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [ft; (String "signal-return")])) then (let saved_kont = (get (frame) ((String "f"))) in (make_cek_value (value) ((get (frame) ((String "env")))) (saved_kont))) else (if sx_truthy ((prim_call "=" [ft; (String "comp-trace")])) then (make_cek_value (value) (env) (rest_k)) else (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown frame type: "); ft])))))))))))))))))))))))))))))))))))))) + (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 (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' = (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))) (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 (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 (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 (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 has_rest_param params then - let () = ignore (bind_lambda_params params args local) 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 ((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_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))]))))))))) + (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 (if not (bind_lambda_with_rest params args local) then begin let pl = sx_to_list params and al = sx_to_list args in if List.length al > List.length pl then raise (Eval_error (Printf.sprintf "%s expects %d args, got %d" (match lambda_name f with String s -> s | _ -> "lambda") (List.length pl) (List.length al))); 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])); List.iter (fun p -> ignore (env_bind local (sx_to_string p) Nil)) (sx_to_list (prim_call "slice" [params; len args])) end; (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_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 = @@ -636,6 +663,19 @@ let () = trampoline_fn := (fun 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) do + s := cek_step !s + done; + cek_value !s + with Eval_error msg -> + _last_error_kont := cek_kont !s; + raise (Eval_error msg)) + (* Collect component trace from a kont value *) let collect_comp_trace kont = let trace = ref [] in diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index 4e18b027..327d7111 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -50,6 +50,8 @@ let sx_call f args = Thunk (l.l_body, local) | Continuation (k, _) -> k (match args with x :: _ -> x | [] -> Nil) + | CallccContinuation _ -> + raise (Eval_error "callcc continuations must be invoked through the CEK machine") | _ -> let nargs = List.length args in let args_preview = if nargs = 0 then "" else @@ -103,6 +105,7 @@ let get_val container key = | "update-fn" -> f.cf_extra | "head-name" -> f.cf_extra | "emitted" -> f.cf_extra2 | "effect-list" -> f.cf_extra2 | "first-render" -> f.cf_extra2 | "file" -> f.cf_env + | "extra" -> f.cf_extra | "extra2" -> f.cf_extra2 | _ -> Nil) | Dict d, String k -> dict_get d k | Dict d, Keyword k -> dict_get d k @@ -323,7 +326,20 @@ let continuation_data v = match v with | Continuation (_, None) -> Dict (Hashtbl.create 0) | _ -> raise (Eval_error "not a continuation") +(* Callcc (undelimited) continuation support *) +let callcc_continuation_p v = match v with CallccContinuation _ -> Bool true | _ -> Bool false + +let make_callcc_continuation captured = + CallccContinuation (sx_to_list captured) + +let callcc_continuation_data v = match v with + | CallccContinuation frames -> List frames + | _ -> raise (Eval_error "not a callcc continuation") + (* Dynamic wind — simplified for OCaml (no async) *) +let host_error msg = + raise (Eval_error (value_to_str msg)) + let dynamic_wind_call before body after _env = ignore (sx_call before []); let result = sx_call body [] in diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index 7a2ac802..b875a51f 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -56,6 +56,7 @@ and value = | Macro of macro | Thunk of value * env | Continuation of (value -> value) * dict option + | CallccContinuation of value list (** Undelimited continuation — captured kont frames *) | NativeFn of string * (value list -> value) | Signal of signal | RawHTML of string @@ -336,6 +337,7 @@ let type_of = function | Macro _ -> "macro" | Thunk _ -> "thunk" | Continuation (_, _) -> "continuation" + | CallccContinuation _ -> "continuation" | NativeFn _ -> "function" | Signal _ -> "signal" | RawHTML _ -> "raw-html" @@ -358,7 +360,7 @@ let is_signal = function | _ -> false let is_callable = function - | Lambda _ | NativeFn _ | Continuation (_, _) | VmClosure _ -> true + | Lambda _ | NativeFn _ | Continuation (_, _) | CallccContinuation _ | VmClosure _ -> true | _ -> false @@ -529,6 +531,7 @@ let rec inspect = function Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params) | Thunk _ -> "" | Continuation (_, _) -> "" + | CallccContinuation _ -> "" | NativeFn (name, _) -> Printf.sprintf "" name | Signal _ -> "" | RawHTML s -> Printf.sprintf "\"\"" (String.length s) diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index 9a1c9846..4837b393 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -1,1324 +1,1857 @@ -;; ========================================================================== -;; ml.sx — SX-to-OCaml translator, written in SX -;; -;; Translates (define ...) forms from .sx spec files into OCaml source. -;; The Python evaluator executes this file against the spec to produce -;; sx_ref.ml — the transpiled evaluator as native OCaml. -;; -;; Usage (from SX): -;; (ml-expr expr) — translate one expression to OCaml -;; (ml-statement expr) — translate to OCaml top-level statement -;; (ml-translate-file defines) — translate a list of (name . define-expr) pairs -;; ========================================================================== +(define + ml-reserved + (list + "and" + "as" + "assert" + "asr" + "begin" + "class" + "constraint" + "do" + "done" + "downto" + "else" + "end" + "exception" + "external" + "false" + "for" + "fun" + "function" + "functor" + "if" + "in" + "include" + "inherit" + "initializer" + "land" + "lazy" + "let" + "lor" + "lsl" + "lsr" + "lxor" + "match" + "method" + "mod" + "module" + "mutable" + "new" + "nonrec" + "object" + "of" + "open" + "or" + "private" + "rec" + "sig" + "struct" + "then" + "to" + "true" + "try" + "type" + "val" + "virtual" + "when" + "while" + "with" + "ref" + "not" + "ignore" + "print" + "list" + "string" + "int" + "float" + "option" + "result")) +(define ml-renames {:eval-expr "eval_expr" :macro-closure "macro_closure" :*render-fn* "render_fn" :thunk-env "thunk_env" :dict-has? "dict_has" :escape-attr "escape_attr" :thunk-expr "thunk_expr" :get-primitive "get_primitive" :*custom-special-forms* "custom_special_forms" :sx-serialize "sx_serialize" :component-closure "component_closure" :lambda-params "lambda_params" :callable? "is_callable" :island? "is_island" :symbol-name "symbol_name" :string-contains? "string_contains_p" :set-lambda-name! "set_lambda_name" :macro? "is_macro" :true "(Bool true)" :keyword-name "keyword_name" :env-bind! "env_bind" :scope-pop! "scope_pop" :BOOLEAN_ATTRS "boolean_attrs" :expand-macro "expand_macro" :contains? "contains_p" :map-dict "map_dict" :*render-check* "render_check" :macro-body "macro_body" :for-each-indexed "for_each_indexed" :emit! "sx_emit" :context "sx_context" :env-extend "env_extend" :spread? "is_spread" :is-else-clause? "is_else_clause" :component-params "component_params" :dict-delete! "dict_delete" :every? "every_p" :make-component "make_component" :lambda-name "lambda_name" :char-from-code "char_from_code" :spread-attrs "spread_attrs" :component-affinity "component_affinity" :component? "is_component" :call-lambda "call_lambda" :make-thunk "make_thunk" :make-symbol "make_symbol" :dict-get "dict_get" :provide-pop! "provide_pop" :component-body "component_body" :make-spread "make_spread" :emitted "sx_emitted" :provide-push! "provide_push" :make-keyword "make_keyword" :scope-emit! "scope_emit" :register-special-form! "register_special_form" :lambda-body "lambda_body" :escape-string "escape_string" :for-each "for_each" :scope-peek "scope_peek" :make-island "make_island" :string-length "string_length" :nil "Nil" :has-key? "has_key_p" :HTML_TAGS "html_tags" :macro-rest-param "macro_rest_param" :env-has? "env_has" :make-raw-html "make_raw_html" :type-of "type_of" :component-name "component_name" :map-indexed "map_indexed" :render-to-html "render_to_html" :env-set! "env_set" :dict-set! "dict_set" :collected "sx_collected" :clear-collected! "sx_clear_collected" :make-macro "make_macro" :identical? "is_identical" :escape-html "escape_html" :starts-with? "starts_with_p" :make-lambda "make_lambda" :empty? "empty_p" :lambda-closure "lambda_closure" :thunk? "is_thunk" :ends-with? "ends_with_p" :component-has-children? "component_has_children" :VOID_ELEMENTS "void_elements" :env-merge "env_merge" :raw-html-content "raw_html_content" :lambda? "is_lambda" :false "(Bool false)" :parse-float "parse_float" :collect! "sx_collect" :nil? "is_nil" :env-get "env_get" :index-of "index_of" :scope-push! "scope_push" :signal? "is_signal" :macro-params "macro_params" :primitive? "is_primitive" :parse-int "parse_int"}) -;; -------------------------------------------------------------------------- -;; OCaml reserved words — names that get _ suffix -;; -------------------------------------------------------------------------- - -(define ml-reserved - (list "and" "as" "assert" "asr" "begin" "class" "constraint" "do" "done" - "downto" "else" "end" "exception" "external" "false" "for" "fun" - "function" "functor" "if" "in" "include" "inherit" "initializer" - "land" "lazy" "let" "lor" "lsl" "lsr" "lxor" "match" "method" - "mod" "module" "mutable" "new" "nonrec" "object" "of" "open" - "or" "private" "rec" "sig" "struct" "then" "to" "true" "try" - "type" "val" "virtual" "when" "while" "with" - "ref" "not" "ignore" "print" "list" "string" "int" "float" - "option" "result")) - - -;; -------------------------------------------------------------------------- -;; RENAMES table — explicit SX name → OCaml name mappings -;; -------------------------------------------------------------------------- - -(define ml-renames { - :nil "Nil" - :true "(Bool true)" - :false "(Bool false)" - "nil?" "is_nil" - "type-of" "type_of" - "symbol-name" "symbol_name" - "keyword-name" "keyword_name" - "make-lambda" "make_lambda" - "make-component" "make_component" - "make-macro" "make_macro" - "make-thunk" "make_thunk" - "make-symbol" "make_symbol" - "make-keyword" "make_keyword" - "lambda-params" "lambda_params" - "lambda-body" "lambda_body" - "lambda-closure" "lambda_closure" - "lambda-name" "lambda_name" - "set-lambda-name!" "set_lambda_name" - "component-params" "component_params" - "component-body" "component_body" - "component-closure" "component_closure" - "component-has-children?" "component_has_children" - "component-name" "component_name" - "component-affinity" "component_affinity" - "macro-params" "macro_params" - "macro-rest-param" "macro_rest_param" - "macro-body" "macro_body" - "macro-closure" "macro_closure" - "thunk?" "is_thunk" - "thunk-expr" "thunk_expr" - "thunk-env" "thunk_env" - "callable?" "is_callable" - "lambda?" "is_lambda" - "component?" "is_component" - "island?" "is_island" - "make-island" "make_island" - "macro?" "is_macro" - "signal?" "is_signal" - "identical?" "is_identical" - "primitive?" "is_primitive" - "get-primitive" "get_primitive" - "env-has?" "env_has" - "env-get" "env_get" - "env-bind!" "env_bind" - "env-set!" "env_set" - "env-extend" "env_extend" - "env-merge" "env_merge" - "dict-set!" "dict_set" - "dict-get" "dict_get" - "dict-has?" "dict_has" - "dict-delete!" "dict_delete" - "eval-expr" "eval_expr" - "call-lambda" "call_lambda" - "expand-macro" "expand_macro" - "render-to-html" "render_to_html" - "escape-html" "escape_html" - "escape-attr" "escape_attr" - "escape-string" "escape_string" - "raw-html-content" "raw_html_content" - "make-raw-html" "make_raw_html" - "make-spread" "make_spread" - "spread?" "is_spread" - "spread-attrs" "spread_attrs" - "contains?" "contains_p" - "starts-with?" "starts_with_p" - "ends-with?" "ends_with_p" - "empty?" "empty_p" - "every?" "every_p" - "for-each" "for_each" - "for-each-indexed" "for_each_indexed" - "map-indexed" "map_indexed" - "map-dict" "map_dict" - "string-length" "string_length" - "string-contains?" "string_contains_p" - "has-key?" "has_key_p" - "index-of" "index_of" - "char-from-code" "char_from_code" - "parse-int" "parse_int" - "parse-float" "parse_float" - "collect!" "sx_collect" - "collected" "sx_collected" - "clear-collected!" "sx_clear_collected" - "context" "sx_context" - "emit!" "sx_emit" - "emitted" "sx_emitted" - "scope-push!" "scope_push" - "scope-pop!" "scope_pop" - "scope-peek" "scope_peek" - "scope-emit!" "scope_emit" - "provide-push!" "provide_push" - "provide-pop!" "provide_pop" - "sx-serialize" "sx_serialize" - "*custom-special-forms*" "custom_special_forms" - "register-special-form!" "register_special_form" - "*render-check*" "render_check" - "*render-fn*" "render_fn" - "is-else-clause?" "is_else_clause" - "HTML_TAGS" "html_tags" - "VOID_ELEMENTS" "void_elements" - "BOOLEAN_ATTRS" "boolean_attrs" -}) - - -;; -------------------------------------------------------------------------- -;; Name mangling: SX identifier → valid OCaml identifier -;; -------------------------------------------------------------------------- - -(define ml-mangle - (fn ((name :as string)) - (let ((renamed (get ml-renames name))) - (if (not (nil? renamed)) +(define + ml-mangle + (fn + ((name :as string)) + (let + ((renamed (get ml-renames name))) + (if + (not (nil? renamed)) renamed - ;; General mangling rules - (let ((result name)) - ;; Handle trailing ? and ! - (let ((result (cond - (ends-with? result "?") - (str (slice result 0 (- (string-length result) 1)) "_p") - (ends-with? result "!") - (str (slice result 0 (- (string-length result) 1)) "_b") - :else result))) - ;; Kebab to snake_case - (let ((result (replace result "-" "_"))) - ;; Handle * wrappers (like *strict*) - (let ((result (replace result "*" "_"))) - ;; Escape OCaml reserved words - (if (some (fn (r) (= r result)) ml-reserved) + (let + ((result name)) + (let + ((result (cond (ends-with? result "?") (str (slice result 0 (- (string-length result) 1)) "_p") (ends-with? result "!") (str (slice result 0 (- (string-length result) 1)) "_b") :else result))) + (let + ((result (replace result "-" "_"))) + (let + ((result (replace result "*" "_"))) + (if + (some (fn (r) (= r result)) ml-reserved) (str result "'") result))))))))) +(define + ml-runtime-names + (list + "env-bind!" + "env-set!" + "env-get" + "env-has?" + "env-extend" + "env-merge" + "make-env" + "make-lambda" + "make-component" + "make-island" + "make-macro" + "make-thunk" + "make-symbol" + "make-keyword" + "set-lambda-name!" + "type-of" + "symbol-name" + "keyword-name" + "inspect" + "lambda-params" + "lambda-body" + "lambda-closure" + "lambda-name" + "component-params" + "component-body" + "component-closure" + "component-has-children?" + "component-name" + "component-affinity" + "macro-params" + "macro-rest-param" + "macro-body" + "macro-closure" + "thunk-expr" + "thunk-env" + "thunk?" + "callable?" + "lambda?" + "component?" + "island?" + "macro?" + "signal?" + "primitive?" + "nil?" + "identical?" + "get-primitive" + "trampoline" + "sx-serialize" + "prim-call" + "first" + "rest" + "last" + "nth" + "cons" + "append" + "reverse" + "flatten" + "concat" + "len" + "get" + "empty?" + "list?" + "dict?" + "number?" + "string?" + "boolean?" + "symbol?" + "keyword?" + "contains?" + "has-key?" + "starts-with?" + "ends-with?" + "string-contains?" + "odd?" + "even?" + "zero?" + "upper" + "upcase" + "lower" + "downcase" + "trim" + "split" + "join" + "replace" + "index-of" + "substring" + "string-length" + "char-from-code" + "keys" + "vals" + "assoc" + "dissoc" + "merge" + "dict-set!" + "dict-get" + "dict-has?" + "dict-delete!" + "abs" + "sqrt" + "pow" + "floor" + "ceil" + "round" + "min" + "max" + "clamp" + "parse-int" + "parse-float" + "error" + "host-error" + "apply" + "make-spread" + "spread?" + "spread-attrs" + "map-indexed" + "map-dict" + "for-each" + "for-each-indexed" + "cek-call" + "cek-run" + "sx-call" + "sx-apply" + "collect!" + "collected" + "clear-collected!" + "context" + "emit!" + "emitted" + "scope-push!" + "scope-pop!" + "provide-push!" + "provide-pop!" + "with-island-scope" + "register-in-scope" + "signal-value" + "signal-set-value" + "signal-subscribers" + "signal-add-sub!" + "signal-remove-sub!" + "signal-deps" + "signal-set-deps" + "notify-subscribers" + "flush-subscribers" + "dispose-computed" + "continuation?" + "continuation-data" + "make-cek-continuation" + "callcc-continuation?" + "callcc-continuation-data" + "make-callcc-continuation" + "dynamic-wind-call" + "strip-prefix" + "component-set-param-types!" + "component-file" + "component-set-file!" + "parse-comp-params" + "parse-macro-params" + "parse-keyword-args")) -;; -------------------------------------------------------------------------- -;; Known name detection — distinguishes static OCaml calls from dynamic SX calls. -;; Names in ml-renames, _known_defines, or ml-runtime-names get direct calls. -;; Unknown names (local variables) use cek_call for dynamic dispatch. -;; -------------------------------------------------------------------------- - -(define ml-runtime-names - (list "env-bind!" "env-set!" "env-get" "env-has?" "env-extend" "env-merge" - "make-env" "make-lambda" "make-component" "make-island" "make-macro" - "make-thunk" "make-symbol" "make-keyword" "set-lambda-name!" - "type-of" "symbol-name" "keyword-name" "inspect" - "lambda-params" "lambda-body" "lambda-closure" "lambda-name" - "component-params" "component-body" "component-closure" - "component-has-children?" "component-name" "component-affinity" - "macro-params" "macro-rest-param" "macro-body" "macro-closure" - "thunk-expr" "thunk-env" "thunk?" "callable?" "lambda?" "component?" - "island?" "macro?" "signal?" "primitive?" "nil?" "identical?" - "get-primitive" "trampoline" "sx-serialize" "prim-call" - "first" "rest" "last" "nth" "cons" "append" "reverse" "flatten" - "concat" "len" "get" "empty?" "list?" "dict?" "number?" "string?" - "boolean?" "symbol?" "keyword?" "contains?" "has-key?" "starts-with?" - "ends-with?" "string-contains?" "odd?" "even?" "zero?" - "upper" "upcase" "lower" "downcase" "trim" "split" "join" - "replace" "index-of" "substring" "string-length" "char-from-code" - "keys" "vals" "assoc" "dissoc" "merge" "dict-set!" "dict-get" - "dict-has?" "dict-delete!" "abs" "sqrt" "pow" "floor" "ceil" - "round" "min" "max" "clamp" "parse-int" "parse-float" - "error" "apply" "make-spread" "spread?" "spread-attrs" - "map-indexed" "map-dict" "for-each" "for-each-indexed" - "cek-call" "cek-run" "sx-call" "sx-apply" - "collect!" "collected" "clear-collected!" "context" "emit!" "emitted" - "scope-push!" "scope-pop!" "provide-push!" "provide-pop!" - "with-island-scope" "register-in-scope" - "signal-value" "signal-set-value" "signal-subscribers" - "signal-add-sub!" "signal-remove-sub!" "signal-deps" "signal-set-deps" - "notify-subscribers" "flush-subscribers" "dispose-computed" - "continuation?" "continuation-data" "make-cek-continuation" - "dynamic-wind-call" "strip-prefix" - "component-set-param-types!" "component-file" "component-set-file!" "parse-comp-params" "parse-macro-params" - "parse-keyword-args")) - -(define ml-is-known-name? - (fn ((name :as string)) - ;; Check renames table - (if (not (nil? (get ml-renames name))) +(define + ml-is-known-name? + (fn + ((name :as string)) + (if + (not (nil? (get ml-renames name))) true - ;; Check runtime names - (if (some (fn (r) (= r name)) ml-runtime-names) + (if + (some (fn (r) (= r name)) ml-runtime-names) true - ;; Check _known_defines (set by bootstrap.py) (some (fn (d) (= d name)) _known_defines))))) -;; Dynamic globals — top-level defines that hold SX values (not functions). -;; When these appear as callees, use cek_call for dynamic dispatch. -(define ml-dynamic-globals - (list "*render-check*" "*render-fn*")) +(define ml-dynamic-globals (list "*render-check*" "*render-fn*")) -(define ml-is-dyn-global? - (fn ((name :as string)) - (some (fn (g) (= g name)) ml-dynamic-globals))) +(define + ml-is-dyn-global? + (fn ((name :as string)) (some (fn (g) (= g name)) ml-dynamic-globals))) -;; Check if a variable is "dynamic" — locally bound to a non-function expression. -;; These variables hold SX values (from eval-expr, get, etc.) and need cek_call -;; when used as callees. We encode this in the set-vars list as "dyn:name". -(define ml-is-dyn-var? - (fn ((name :as string) (set-vars :as list)) +(define + ml-is-dyn-var? + (fn + ((name :as string) (set-vars :as list)) (some (fn (v) (= v (str "dyn:" name))) set-vars))) +(define + ml-quote-string + (fn + ((s :as string)) + (str + "\"" + (replace + (replace (replace (replace s "\\" "\\\\") "\"" "\\\"") "\n" "\\n") + "\t" + "\\t") + "\""))) -;; -------------------------------------------------------------------------- -;; String quoting for OCaml -;; -------------------------------------------------------------------------- +(define + ml-is-self-recursive? + (fn ((name :as string) body) (ml-scan-for-name name body))) -(define ml-quote-string - (fn ((s :as string)) - (str "\"" (replace (replace (replace (replace s "\\" "\\\\") "\"" "\\\"") "\n" "\\n") "\t" "\\t") "\""))) - - -;; -------------------------------------------------------------------------- -;; Detect self-recursion in a define body -;; -------------------------------------------------------------------------- - -(define ml-is-self-recursive? - (fn ((name :as string) body) - (ml-scan-for-name name body))) - -(define ml-scan-for-name - (fn ((name :as string) node) +(define + ml-scan-for-name + (fn + ((name :as string) node) (cond - (and (= (type-of node) "symbol") (= (symbol-name node) name)) true + (and (= (type-of node) "symbol") (= (symbol-name node) name)) + true (list? node) - (some (fn (child) (ml-scan-for-name name child)) node) + (some (fn (child) (ml-scan-for-name name child)) node) :else false))) +(define + ml-find-let-bound-names + (fn + ((body :as list)) + (let + ((result (list))) + (begin (for-each (fn (b) (ml-scan-let-names b result)) body) result)))) -;; -------------------------------------------------------------------------- -;; let-bound name detection — find variables bound by let in the body -;; -------------------------------------------------------------------------- - -(define ml-find-let-bound-names - (fn ((body :as list)) - (let ((result (list))) - (begin - (for-each (fn (b) (ml-scan-let-names b result)) body) - result)))) - -(define ml-scan-let-names - (fn (node (result :as list)) - (when (and (list? node) (not (empty? node))) - (let ((head (first node))) +(define + ml-scan-let-names + (fn + (node (result :as list)) + (when + (and (list? node) (not (empty? node))) + (let + ((head (first node))) (cond - (and (= (type-of head) "symbol") - (or (= (symbol-name head) "let") (= (symbol-name head) "let*")) - (>= (len node) 2) - (list? (nth node 1))) - (let ((bindings (nth node 1))) - (begin - ;; Extract bound names from let bindings - (if (and (not (empty? bindings)) (list? (first bindings))) - ;; Scheme-style: ((name val) ...) - (for-each (fn (b) - (when (and (list? b) (>= (len b) 1)) - (let ((vname (if (= (type-of (first b)) "symbol") - (ml-mangle (symbol-name (first b))) - (str (first b))))) - (when (not (some (fn (x) (= x vname)) result)) + (and + (= (type-of head) "symbol") + (or (= (symbol-name head) "let") (= (symbol-name head) "let*")) + (>= (len node) 2) + (list? (nth node 1))) + (let + ((bindings (nth node 1))) + (begin + (if + (and (not (empty? bindings)) (list? (first bindings))) + (for-each + (fn + (b) + (when + (and (list? b) (>= (len b) 1)) + (let + ((vname (if (= (type-of (first b)) "symbol") (ml-mangle (symbol-name (first b))) (str (first b))))) + (when + (not (some (fn (x) (= x vname)) result)) (append! result vname))))) - bindings) - ;; Clojure-style: (name val name val ...) - (let ((i 0)) - (for-each (fn (item) - (when (= (mod i 2) 0) - (let ((vname (if (= (type-of item) "symbol") - (ml-mangle (symbol-name item)) - (str item)))) - (when (not (some (fn (x) (= x vname)) result)) + bindings) + (let + ((i 0)) + (for-each + (fn + (item) + (when + (= (mod i 2) 0) + (let + ((vname (if (= (type-of item) "symbol") (ml-mangle (symbol-name item)) (str item)))) + (when + (not (some (fn (x) (= x vname)) result)) (append! result vname))))) - bindings))) - ;; Also scan body of let for more let-bound names - (for-each (fn (child) (ml-scan-let-names child result)) - (rest (rest node))))) - :else - (for-each (fn (child) - (when (list? child) - (ml-scan-let-names child result))) - node)))))) + bindings))) + (for-each + (fn (child) (ml-scan-let-names child result)) + (rest (rest node))))) + :else (for-each + (fn + (child) + (when (list? child) (ml-scan-let-names child result))) + node)))))) +(define + ml-find-set-targets + (fn + ((body :as list)) + (let + ((result (list))) + (begin (for-each (fn (b) (ml-scan-set b result)) body) result)))) -;; -------------------------------------------------------------------------- -;; set! target detection — find variables that need ref -;; -------------------------------------------------------------------------- - -(define ml-find-set-targets - (fn ((body :as list)) - (let ((result (list))) - (begin - (for-each (fn (b) (ml-scan-set b result)) body) - result)))) - -(define ml-scan-set - (fn (node (result :as list)) - (when (and (list? node) (not (empty? node))) - (let ((head (first node))) +(define + ml-scan-set + (fn + (node (result :as list)) + (when + (and (list? node) (not (empty? node))) + (let + ((head (first node))) (cond - ;; set! targets - (and (= (type-of head) "symbol") - (= (symbol-name head) "set!") - (>= (len node) 2)) - (let ((var-name (if (= (type-of (nth node 1)) "symbol") - (symbol-name (nth node 1)) - (str (nth node 1))))) - (let ((mangled (ml-mangle var-name))) - (when (not (some (fn (x) (= x mangled)) result)) - (append! result mangled)))) - ;; append! targets — need ref wrapping just like set! - (and (= (type-of head) "symbol") - (= (symbol-name head) "append!") - (>= (len node) 2) - (= (type-of (nth node 1)) "symbol")) - (let ((var-name (symbol-name (nth node 1)))) - (let ((mangled (ml-mangle var-name))) - (when (not (some (fn (x) (= x mangled)) result)) - (append! result mangled)))) - :else - (for-each (fn (child) - (when (list? child) - (ml-scan-set child result))) - node)))))) + (and + (= (type-of head) "symbol") + (= (symbol-name head) "set!") + (>= (len node) 2)) + (let + ((var-name (if (= (type-of (nth node 1)) "symbol") (symbol-name (nth node 1)) (str (nth node 1))))) + (let + ((mangled (ml-mangle var-name))) + (when + (not (some (fn (x) (= x mangled)) result)) + (append! result mangled)))) + (and + (= (type-of head) "symbol") + (= (symbol-name head) "append!") + (>= (len node) 2) + (= (type-of (nth node 1)) "symbol")) + (let + ((var-name (symbol-name (nth node 1)))) + (let + ((mangled (ml-mangle var-name))) + (when + (not (some (fn (x) (= x mangled)) result)) + (append! result mangled)))) + :else (for-each + (fn (child) (when (list? child) (ml-scan-set child result))) + node)))))) +(define ml-expr (fn (expr) (ml-expr-inner expr (list)))) -;; -------------------------------------------------------------------------- -;; Expression translator: SX AST → OCaml expression string -;; -------------------------------------------------------------------------- - -(define ml-expr - (fn (expr) - (ml-expr-inner expr (list)))) - -(define ml-expr-inner - (fn (expr (set-vars :as list)) +(define + ml-expr-inner + (fn + (expr (set-vars :as list)) (cond - ;; Bool (= (type-of expr) "boolean") - (if expr "(Bool true)" "(Bool false)") - - ;; Nil - (nil? expr) "Nil" - - ;; Numbers — ensure float suffix for OCaml + (if expr "(Bool true)" "(Bool false)") + (nil? expr) + "Nil" (number? expr) - (if (string-contains? (str expr) ".") - (str "(Number " (str expr) ")") - (str "(Number " (str expr) ".0)")) - - ;; Strings + (if + (string-contains? (str expr) ".") + (str "(Number " (str expr) ")") + (str "(Number " (str expr) ".0)")) (string? expr) - (str "(String " (ml-quote-string expr) ")") - - ;; Symbols + (str "(String " (ml-quote-string expr) ")") (= (type-of expr) "symbol") - (let ((mangled (ml-mangle (symbol-name expr)))) - (if (some (fn (c) (= c mangled)) set-vars) - (str "!" mangled) - mangled)) - - ;; Keywords → string value + (let + ((mangled (ml-mangle (symbol-name expr)))) + (if + (some (fn (c) (= c mangled)) set-vars) + (str "!" mangled) + mangled)) (= (type-of expr) "keyword") - (str "(String " (ml-quote-string (keyword-name expr)) ")") - - ;; Dicts + (str "(String " (ml-quote-string (keyword-name expr)) ")") (= (type-of expr) "dict") - (ml-emit-dict-native expr set-vars) - - ;; Lists + (ml-emit-dict-native expr set-vars) (list? expr) - (if (empty? expr) - "[]" - (ml-emit-list expr set-vars)) - - ;; Fallback + (if (empty? expr) "[]" (ml-emit-list expr set-vars)) :else (str "(* ??? *) " (str expr))))) +(define + ml-emit-dict-native + (fn + ((d :as dict) (set-vars :as list)) + (let + ((items (keys d))) + (if + (and + (= (len items) 5) + (some (fn (k) (= k "control")) items) + (some (fn (k) (= k "phase")) items) + (some (fn (k) (= k "kont")) items)) + (str + "(CekState { cs_control = " + (ml-expr-inner (get d "control") set-vars) + "; cs_env = " + (ml-expr-inner (get d "env") set-vars) + "; cs_kont = " + (ml-expr-inner (get d "kont") set-vars) + "; cs_phase = " + (let + ((p (get d "phase"))) + (if + (= (type-of p) "string") + (ml-quote-string p) + (str + "(match " + (ml-expr-inner p set-vars) + " with String s -> s | _ -> \"\")"))) + "; cs_value = " + (ml-expr-inner (get d "value") set-vars) + " })") + (if + (and + (some (fn (k) (= k "type")) items) + (= (type-of (get d "type")) "string")) + (let + ((frame-type (get d "type")) + (ef + (fn + (field) + (if + (some (fn (k) (= k field)) items) + (ml-expr-inner (get d field) set-vars) + "Nil")))) + (str + "(CekFrame { cf_type = " + (ml-quote-string frame-type) + "; cf_env = " + (ef "env") + "; cf_name = " + (if (= frame-type "if") (ef "else") (ef "name")) + "; cf_body = " + (if (= frame-type "if") (ef "then") (ef "body")) + "; cf_remaining = " + (ef "remaining") + "; cf_f = " + (ef "f") + "; cf_args = " + (cond + (some (fn (k) (= k "evaled")) items) + (ef "evaled") + (some (fn (k) (= k "args")) items) + (ef "args") + :else "Nil") + "; cf_results = " + (cond + (some (fn (k) (= k "results")) items) + (ef "results") + (some (fn (k) (= k "raw-args")) items) + (ef "raw-args") + :else "Nil") + "; cf_extra = " + (cond + (some (fn (k) (= k "ho-type")) items) + (ef "ho-type") + (some (fn (k) (= k "scheme")) items) + (ef "scheme") + (some (fn (k) (= k "indexed")) items) + (ef "indexed") + (some (fn (k) (= k "value")) items) + (ef "value") + (some (fn (k) (= k "phase")) items) + (ef "phase") + (some (fn (k) (= k "has-effects")) items) + (ef "has-effects") + (some (fn (k) (= k "match-val")) items) + (ef "match-val") + (some (fn (k) (= k "current-item")) items) + (ef "current-item") + (some (fn (k) (= k "update-fn")) items) + (ef "update-fn") + (some (fn (k) (= k "head-name")) items) + (ef "head-name") + :else "Nil") + "; cf_extra2 = " + (cond + (some (fn (k) (= k "emitted")) items) + (ef "emitted") + (some (fn (k) (= k "effect-list")) items) + (ef "effect-list") + (some (fn (k) (= k "first-render")) items) + (ef "first-render") + :else "Nil") + " })")) + (str + "(let _d = Hashtbl.create " + (str (round (len items))) + " in " + (join + "; " + (map + (fn + (k) + (str + "Hashtbl.replace _d " + (ml-quote-string k) + " " + (ml-expr-inner (get d k) set-vars))) + items)) + "; Dict _d)")))))) -;; -------------------------------------------------------------------------- -;; Dict emission -;; -------------------------------------------------------------------------- - -(define ml-emit-dict-native - (fn ((d :as dict) (set-vars :as list)) - (let ((items (keys d))) - ;; Optimize CEK state dicts — emit CekState record instead of Hashtbl. - ;; Detected by having exactly {control, env, kont, phase, value} keys. - (if (and (= (len items) 5) - (some (fn (k) (= k "control")) items) - (some (fn (k) (= k "phase")) items) - (some (fn (k) (= k "kont")) items)) - (str "(CekState { cs_control = " (ml-expr-inner (get d "control") set-vars) - "; cs_env = " (ml-expr-inner (get d "env") set-vars) - "; cs_kont = " (ml-expr-inner (get d "kont") set-vars) - "; cs_phase = " (let ((p (get d "phase"))) - (if (= (type-of p) "string") - (ml-quote-string p) - (str "(match " (ml-expr-inner p set-vars) - " with String s -> s | _ -> \"\")"))) - "; cs_value = " (ml-expr-inner (get d "value") set-vars) - " })") - ;; Optimize CEK frame dicts — detected by having a "type" string field. - ;; Maps frame fields to generic CekFrame record slots. - (if (and (some (fn (k) (= k "type")) items) - (= (type-of (get d "type")) "string")) - (let ((frame-type (get d "type")) - (ef (fn (field) (if (some (fn (k) (= k field)) items) - (ml-expr-inner (get d field) set-vars) "Nil")))) - (str "(CekFrame { cf_type = " (ml-quote-string frame-type) - "; cf_env = " (ef "env") - "; cf_name = " (if (= frame-type "if") (ef "else") (ef "name")) - "; cf_body = " (if (= frame-type "if") (ef "then") (ef "body")) - "; cf_remaining = " (ef "remaining") - "; cf_f = " (ef "f") - "; cf_args = " (cond - (some (fn (k) (= k "evaled")) items) (ef "evaled") - (some (fn (k) (= k "args")) items) (ef "args") - :else "Nil") - "; cf_results = " (cond - (some (fn (k) (= k "results")) items) (ef "results") - (some (fn (k) (= k "raw-args")) items) (ef "raw-args") - :else "Nil") - "; cf_extra = " (cond - (some (fn (k) (= k "ho-type")) items) (ef "ho-type") - (some (fn (k) (= k "scheme")) items) (ef "scheme") - (some (fn (k) (= k "indexed")) items) (ef "indexed") - (some (fn (k) (= k "value")) items) (ef "value") - (some (fn (k) (= k "phase")) items) (ef "phase") - (some (fn (k) (= k "has-effects")) items) (ef "has-effects") - (some (fn (k) (= k "match-val")) items) (ef "match-val") - (some (fn (k) (= k "current-item")) items) (ef "current-item") - (some (fn (k) (= k "update-fn")) items) (ef "update-fn") - (some (fn (k) (= k "head-name")) items) (ef "head-name") - :else "Nil") - "; cf_extra2 = " (cond - (some (fn (k) (= k "emitted")) items) (ef "emitted") - (some (fn (k) (= k "effect-list")) items) (ef "effect-list") - (some (fn (k) (= k "first-render")) items) (ef "first-render") - :else "Nil") - " })")) - ;; Regular dict — Hashtbl - (str "(let _d = Hashtbl.create " (str (round (len items))) - " in " (join "; " (map (fn (k) - (str "Hashtbl.replace _d " (ml-quote-string k) - " " (ml-expr-inner (get d k) set-vars))) - items)) - "; Dict _d)")))))) - - -;; -------------------------------------------------------------------------- -;; List/call emission — the main dispatch -;; -------------------------------------------------------------------------- - -(define ml-emit-list - (fn (expr (set-vars :as list)) - (let ((head (first expr)) - (args (rest expr))) - (if (not (= (type-of head) "symbol")) - ;; Non-symbol head: if head is a list (call expr), dispatch via cek_call; - ;; otherwise treat as data list - (if (list? head) - (str "(cek_call (" (ml-expr-inner head set-vars) - ") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))") - (str "[" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) expr)) "]")) - (let ((op (symbol-name head))) +(define + ml-emit-list + (fn + (expr (set-vars :as list)) + (let + ((head (first expr)) (args (rest expr))) + (if + (not (= (type-of head) "symbol")) + (if + (list? head) + (str + "(cek_call (" + (ml-expr-inner head set-vars) + ") (List [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "]))") + (str + "[" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) expr)) + "]")) + (let + ((op (symbol-name head))) (cond - ;; fn/lambda (or (= op "fn") (= op "lambda")) - (ml-emit-fn expr set-vars) - - ;; let/let* + (ml-emit-fn expr set-vars) (or (= op "let") (= op "let*")) - (ml-emit-let expr set-vars) - - ;; if + (ml-emit-let expr set-vars) (= op "if") - (let ((cond-e (ml-expr-inner (nth args 0) set-vars)) - (then-e (ml-expr-inner (nth args 1) set-vars)) - (else-e (if (>= (len args) 3) - (ml-expr-inner (nth args 2) set-vars) - "Nil"))) - (str "(if sx_truthy (" cond-e ") then " then-e " else " else-e ")")) - - ;; when + (let + ((cond-e (ml-expr-inner (nth args 0) set-vars)) + (then-e (ml-expr-inner (nth args 1) set-vars)) + (else-e + (if + (>= (len args) 3) + (ml-expr-inner (nth args 2) set-vars) + "Nil"))) + (str + "(if sx_truthy (" + cond-e + ") then " + then-e + " else " + else-e + ")")) (= op "when") - (ml-emit-when expr set-vars) - - ;; cond + (ml-emit-when expr set-vars) (= op "cond") - (ml-emit-cond args set-vars) - - ;; case - (= op "case") - (ml-emit-case args set-vars) - - ;; and + (ml-emit-cond args set-vars) + (or (= op "case") (= op "match")) + (ml-emit-case args set-vars) (= op "and") - (ml-emit-and args set-vars) - - ;; or + (ml-emit-and args set-vars) (= op "or") - (ml-emit-or args set-vars) - - ;; not + (ml-emit-or args set-vars) (= op "not") - (str "(Bool (not (sx_truthy (" (ml-expr-inner (first args) set-vars) "))))") - - ;; do/begin + (str + "(Bool (not (sx_truthy (" + (ml-expr-inner (first args) set-vars) + "))))") (or (= op "do") (= op "begin")) - (ml-emit-do args set-vars) - - ;; list literal + (ml-emit-do args set-vars) (= op "list") - (str "(List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") - - ;; dict literal + (str + "(List [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "dict") - (ml-emit-dict-call args set-vars) - - ;; quote + (ml-emit-dict-call args set-vars) (= op "quote") - (ml-emit-quote (first args)) - - ;; set! + (ml-emit-quote (first args)) (= op "set!") - (let ((var-name (if (= (type-of (first args)) "symbol") - (symbol-name (first args)) - (str (first args))))) - (let ((mangled (ml-mangle var-name))) - (str "(" mangled " := " (ml-expr-inner (nth args 1) set-vars) "; Nil)"))) - - ;; str — concatenate + (let + ((var-name (if (= (type-of (first args)) "symbol") (symbol-name (first args)) (str (first args))))) + (let + ((mangled (ml-mangle var-name))) + (str + "(" + mangled + " := " + (ml-expr-inner (nth args 1) set-vars) + "; Nil)"))) (= op "str") - (str "(String (sx_str [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))") - - ;; error + (str + "(String (sx_str [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "]))") (= op "error") - (str "(raise (Eval_error (value_to_str " (ml-expr-inner (first args) set-vars) ")))") - - ;; Infix arithmetic — emit as primitive calls + (str + "(raise (Eval_error (value_to_str " + (ml-expr-inner (first args) set-vars) + ")))") (= op "+") - (str "(prim_call \"+\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") + (str + "(prim_call \"+\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "-") - (str "(prim_call \"-\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") + (str + "(prim_call \"-\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "*") - (str "(prim_call \"*\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") + (str + "(prim_call \"*\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "/") - (str "(prim_call \"/\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") + (str + "(prim_call \"/\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "mod") - (str "(prim_call \"mod\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") - - ;; Comparison — emit as primitive calls + (str + "(prim_call \"mod\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "=") - (str "(prim_call \"=\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") + (str + "(prim_call \"=\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "!=") - (str "(prim_call \"!=\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") + (str + "(prim_call \"!=\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "<") - (str "(prim_call \"<\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") + (str + "(prim_call \"<\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op ">") - (str "(prim_call \">\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") + (str + "(prim_call \">\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "<=") - (str "(prim_call \"<=\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") + (str + "(prim_call \"<=\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op ">=") - (str "(prim_call \">=\" [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") - - ;; apply + (str + "(prim_call \">=\" [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "apply") - (str "(sx_apply " (ml-expr-inner (first args) set-vars) - " " (ml-expr-inner (nth args 1) set-vars) ")") - - ;; for-each + (str + "(sx_apply " + (ml-expr-inner (first args) set-vars) + " " + (ml-expr-inner (nth args 1) set-vars) + ")") (= op "for-each") - (ml-emit-for-each args set-vars) - - ;; map, filter, reduce, some, every? + (ml-emit-for-each args set-vars) (= op "map") - (ml-emit-ho-form "List.map" "(fun _x -> " ")" "List" args set-vars) + (ml-emit-ho-form "List.map" "(fun _x -> " ")" "List" args set-vars) (= op "map-indexed") - (ml-emit-ho-indexed args set-vars) + (ml-emit-ho-indexed args set-vars) (= op "filter") - (ml-emit-ho-form "List.filter" "(fun _x -> sx_truthy (" "))" "List" args set-vars) + (ml-emit-ho-form + "List.filter" + "(fun _x -> sx_truthy (" + "))" + "List" + args + set-vars) (= op "reduce") - (ml-emit-reduce args set-vars) + (ml-emit-reduce args set-vars) (= op "some") - (ml-emit-ho-form "List.exists" "(fun _x -> sx_truthy (" "))" "Bool" args set-vars) + (ml-emit-ho-form + "List.exists" + "(fun _x -> sx_truthy (" + "))" + "Bool" + args + set-vars) (= op "every?") - (ml-emit-ho-form "List.for_all" "(fun _x -> sx_truthy (" "))" "Bool" args set-vars) - - ;; map-dict — inline lambda optimization + (ml-emit-ho-form + "List.for_all" + "(fun _x -> sx_truthy (" + "))" + "Bool" + args + set-vars) (= op "map-dict") - (ml-emit-map-dict args set-vars) - - ;; Mutation forms + (ml-emit-map-dict args set-vars) (= op "append!") - (let ((target (nth args 0)) - (item-expr (ml-expr-inner (nth args 1) set-vars))) - (if (and (= (type-of target) "symbol") - (some (fn (v) (= v (ml-mangle (symbol-name target)))) set-vars)) - ;; Target is a ref variable — emit ref mutation - (let ((mangled (ml-mangle (symbol-name target)))) - (str "(" mangled " := sx_append_b !" mangled " " item-expr "; Nil)")) - ;; Not a ref — fallback (returns new list) - (str "(sx_append_b " (ml-expr-inner target set-vars) - " " item-expr ")"))) - + (let + ((target (nth args 0)) + (item-expr (ml-expr-inner (nth args 1) set-vars))) + (if + (and + (= (type-of target) "symbol") + (some + (fn (v) (= v (ml-mangle (symbol-name target)))) + set-vars)) + (let + ((mangled (ml-mangle (symbol-name target)))) + (str + "(" + mangled + " := sx_append_b !" + mangled + " " + item-expr + "; Nil)")) + (str + "(sx_append_b " + (ml-expr-inner target set-vars) + " " + item-expr + ")"))) (= op "dict-set!") - (str "(sx_dict_set_b " (ml-expr-inner (nth args 0) set-vars) - " " (ml-expr-inner (nth args 1) set-vars) - " " (ml-expr-inner (nth args 2) set-vars) ")") - + (str + "(sx_dict_set_b " + (ml-expr-inner (nth args 0) set-vars) + " " + (ml-expr-inner (nth args 1) set-vars) + " " + (ml-expr-inner (nth args 2) set-vars) + ")") (= op "env-bind!") - (str "(env_bind " (ml-expr-inner (nth args 0) set-vars) - " (sx_to_string " (ml-expr-inner (nth args 1) set-vars) ")" - " " (ml-expr-inner (nth args 2) set-vars) ")") - + (str + "(env_bind " + (ml-expr-inner (nth args 0) set-vars) + " (sx_to_string " + (ml-expr-inner (nth args 1) set-vars) + ")" + " " + (ml-expr-inner (nth args 2) set-vars) + ")") (= op "env-set!") - (str "(env_set " (ml-expr-inner (nth args 0) set-vars) - " (sx_to_string " (ml-expr-inner (nth args 1) set-vars) ")" - " " (ml-expr-inner (nth args 2) set-vars) ")") - + (str + "(env_set " + (ml-expr-inner (nth args 0) set-vars) + " (sx_to_string " + (ml-expr-inner (nth args 1) set-vars) + ")" + " " + (ml-expr-inner (nth args 2) set-vars) + ")") (= op "set-lambda-name!") - (str "(set_lambda_name " (ml-expr-inner (nth args 0) set-vars) - " (sx_to_string " (ml-expr-inner (nth args 1) set-vars) "))") - - ;; Variadic primitives — always use prim_call - (or (= op "slice") (= op "concat") (= op "range") - (= op "sort") (= op "merge") (= op "round") - (= op "min") (= op "max") (= op "substring") - (= op "assoc") (= op "dissoc") (= op "append") - (= op "flatten") (= op "unique") (= op "zip") - (= op "take") (= op "drop") (= op "chunk-every") - (= op "zip-pairs") (= op "format") (= op "replace") - (= op "split") (= op "join") (= op "index-of") - (= op "dict") (= op "keys") (= op "vals") - (= op "has-key?") (= op "contains?") - (= op "starts-with?") (= op "ends-with?") - (= op "string-contains?") (= op "string-length")) - (str "(prim_call " (ml-quote-string op) " [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "])") - - ;; inc/dec inlined + (str + "(set_lambda_name " + (ml-expr-inner (nth args 0) set-vars) + " (sx_to_string " + (ml-expr-inner (nth args 1) set-vars) + "))") + (or + (= op "slice") + (= op "concat") + (= op "range") + (= op "sort") + (= op "merge") + (= op "round") + (= op "min") + (= op "max") + (= op "substring") + (= op "assoc") + (= op "dissoc") + (= op "append") + (= op "flatten") + (= op "unique") + (= op "zip") + (= op "take") + (= op "drop") + (= op "chunk-every") + (= op "zip-pairs") + (= op "format") + (= op "replace") + (= op "split") + (= op "join") + (= op "index-of") + (= op "dict") + (= op "keys") + (= op "vals") + (= op "has-key?") + (= op "contains?") + (= op "starts-with?") + (= op "ends-with?") + (= op "string-contains?") + (= op "string-length")) + (str + "(prim_call " + (ml-quote-string op) + " [" + (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) + "])") (= op "inc") - (str "(prim_call \"inc\" [" (ml-expr-inner (first args) set-vars) "])") + (str + "(prim_call \"inc\" [" + (ml-expr-inner (first args) set-vars) + "])") (= op "dec") - (str "(prim_call \"dec\" [" (ml-expr-inner (first args) set-vars) "])") + (str + "(prim_call \"dec\" [" + (ml-expr-inner (first args) set-vars) + "])") + :else (let + ((callee (ml-mangle op))) + (if + (or (ml-is-dyn-var? op set-vars) (ml-is-dyn-global? op)) + (str + "(cek_call (" + callee + ") (List [" + (join + "; " + (map (fn (x) (ml-expr-inner x set-vars)) args)) + "]))") + (if + (empty? args) + (str "(" callee " ())") + (str + "(" + callee + " " + (join + " " + (map + (fn (x) (str "(" (ml-expr-inner x set-vars) ")")) + args)) + ")")))))))))) - ;; Regular function call - :else - (let ((callee (ml-mangle op))) - (if (or (ml-is-dyn-var? op set-vars) (ml-is-dyn-global? op)) - ;; Dynamic callee (local var or dynamic global) — dispatch via cek_call - (str "(cek_call (" callee ") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))") - ;; Static callee — direct OCaml call - (if (empty? args) - (str "(" callee " ())") - (str "(" callee " " (join " " (map (fn (x) (str "(" (ml-expr-inner x set-vars) ")")) args)) ")")))))))))) - - -;; -------------------------------------------------------------------------- -;; fn/lambda -;; -------------------------------------------------------------------------- - -;; ml-emit-fn-bare: emit a plain OCaml function (fun params -> body). -;; Used by HO form inlining where a bare OCaml closure is needed. -(define ml-emit-fn-bare - (fn (expr (set-vars :as list)) - (let ((params (nth expr 1)) - (body (rest (rest expr))) - (param-strs (ml-collect-params params)) - (body-set-vars (ml-find-set-targets body)) - (let-bound (ml-find-let-bound-names body))) - (let ((params-str (if (empty? param-strs) "()" (join " " param-strs))) - (all-set-vars (append set-vars body-set-vars)) - ;; Only pre-declare refs for set! targets NOT rebound by let - (needs-ref (filter (fn (v) (not (some (fn (lb) (= lb v)) let-bound))) body-set-vars))) - (if (empty? body-set-vars) - ;; No set! targets — simple function - (if (= (len body) 1) - (str "(fun " params-str " -> " (ml-expr-inner (first body) all-set-vars) ")") +(define + ml-emit-fn-bare + (fn + (expr (set-vars :as list)) + (let + ((params (nth expr 1)) + (body (rest (rest expr))) + (param-strs (ml-collect-params params)) + (body-set-vars (ml-find-set-targets body)) + (let-bound (ml-find-let-bound-names body))) + (let + ((params-str (if (empty? param-strs) "()" (join " " param-strs))) + (all-set-vars (append set-vars body-set-vars)) + (needs-ref + (filter + (fn (v) (not (some (fn (lb) (= lb v)) let-bound))) + body-set-vars))) + (if + (empty? body-set-vars) + (if + (= (len body) 1) + (str + "(fun " + params-str + " -> " + (ml-expr-inner (first body) all-set-vars) + ")") (str "(fun " params-str " -> " (ml-emit-do body all-set-vars) ")")) - ;; Has set! targets — emit ref bindings only for non-let-bound vars - (let ((ref-decls (if (empty? needs-ref) "" - (str (join " " (map (fn (v) (str "let " v " = ref Nil in")) needs-ref)) " "))) - (body-str (if (= (len body) 1) - (ml-expr-inner (first body) all-set-vars) - (ml-emit-do body all-set-vars)))) + (let + ((ref-decls (if (empty? needs-ref) "" (str (join " " (map (fn (v) (str "let " v " = ref Nil in")) needs-ref)) " "))) + (body-str + (if + (= (len body) 1) + (ml-expr-inner (first body) all-set-vars) + (ml-emit-do body all-set-vars)))) (str "(fun " params-str " -> " ref-decls body-str ")"))))))) -;; ml-emit-fn: emit an SX-compatible NativeFn value. -;; Wraps the OCaml closure so it can be stored as a value, passed to -;; signal-add-sub!, etc. The args pattern-match unpacks the value list. -(define ml-emit-fn - (fn (expr (set-vars :as list)) - (let ((params (nth expr 1)) - (param-strs (ml-collect-params params)) - (n (len param-strs)) - (bare (ml-emit-fn-bare expr set-vars))) - (if (= n 0) - ;; Zero-arg: NativeFn("λ", fun _args -> body) +(define + ml-emit-fn + (fn + (expr (set-vars :as list)) + (let + ((params (nth expr 1)) + (param-strs (ml-collect-params params)) + (n (len param-strs)) + (bare (ml-emit-fn-bare expr set-vars))) + (if + (= n 0) (str "(NativeFn (\"\\206\\187\", fun _args -> " bare " ()))") - ;; N-arg: NativeFn("λ", fun args -> match args with [a;b;...] -> body | _ -> Nil) - (let ((match-pat (str "[" (join "; " param-strs) "]")) - (call-args (join " " param-strs))) - (str "(NativeFn (\"\\206\\187\", fun _args -> match _args with " - match-pat " -> " bare " " call-args - " | _ -> Nil))")))))) + (let + ((match-pat (str "[" (join "; " param-strs) "]")) + (call-args (join " " param-strs))) + (str + "(NativeFn (\"\\206\\187\", fun _args -> match _args with " + match-pat + " -> " + bare + " " + call-args + " | _ -> Nil))")))))) -(define ml-collect-params - (fn ((params :as list)) - (ml-collect-params-loop params 0 (list)))) +(define + ml-collect-params + (fn ((params :as list)) (ml-collect-params-loop params 0 (list)))) -(define ml-collect-params-loop - (fn ((params :as list) (i :as number) (result :as list)) - (if (>= i (len params)) +(define + ml-collect-params-loop + (fn + ((params :as list) (i :as number) (result :as list)) + (if + (>= i (len params)) result - (let ((p (nth params i))) + (let + ((p (nth params i))) (cond - ;; &key — skip (components handle this differently) (and (= (type-of p) "symbol") (= (symbol-name p) "&key")) - (ml-collect-params-loop params (+ i 1) result) - ;; &rest + (ml-collect-params-loop params (+ i 1) result) (and (= (type-of p) "symbol") (= (symbol-name p) "&rest")) - (ml-collect-params-loop params (+ i 2) result) - ;; Annotated: (name :as type) - (and (= (type-of p) "list") (= (len p) 3) - (= (type-of (nth p 1)) "keyword") - (= (keyword-name (nth p 1)) "as")) - (ml-collect-params-loop params (+ i 1) - (append result (ml-mangle (symbol-name (first p))))) - ;; Simple symbol + (ml-collect-params-loop params (+ i 2) result) + (and + (= (type-of p) "list") + (= (len p) 3) + (= (type-of (nth p 1)) "keyword") + (= (keyword-name (nth p 1)) "as")) + (ml-collect-params-loop + params + (+ i 1) + (append result (ml-mangle (symbol-name (first p))))) (= (type-of p) "symbol") - (ml-collect-params-loop params (+ i 1) - (append result (ml-mangle (symbol-name p)))) - :else - (ml-collect-params-loop params (+ i 1) - (append result (str p)))))))) + (ml-collect-params-loop + params + (+ i 1) + (append result (ml-mangle (symbol-name p)))) + :else (ml-collect-params-loop params (+ i 1) (append result (str p)))))))) - -;; -------------------------------------------------------------------------- -;; let → OCaml let ... in ... -;; -------------------------------------------------------------------------- - -(define ml-emit-let - (fn (expr (set-vars :as list)) - (let ((bindings (nth expr 1)) - (body (rest (rest expr)))) - (let ((parsed (ml-parse-bindings-full bindings set-vars))) - ;; Track dynamic vars: let-bound vars whose init is NOT a fn/lambda - (let ((dyn-additions (reduce (fn (acc b) - (let ((vname (first b)) - (is-fn (nth b 2))) - (if is-fn acc (append acc (str "dyn:" vname))))) - (list) parsed))) - (let ((body-set-vars (append set-vars dyn-additions))) - (let ((binding-strs (map (fn (b) - (let ((vname (first b)) - (vval (nth b 1))) - (if (some (fn (sv) (= sv vname)) set-vars) - (str "let " vname " = ref (" vval ") in") - (str "let " vname " = " vval " in")))) - parsed)) - (body-str (if (= (len body) 1) - (ml-expr-inner (first body) body-set-vars) - (ml-emit-do body body-set-vars)))) +(define + ml-emit-let + (fn + (expr (set-vars :as list)) + (let + ((bindings (nth expr 1)) (body (rest (rest expr)))) + (let + ((parsed (ml-parse-bindings-full bindings set-vars))) + (let + ((dyn-additions (reduce (fn (acc b) (let ((vname (first b)) (is-fn (nth b 2))) (if is-fn acc (append acc (str "dyn:" vname))))) (list) parsed))) + (let + ((body-set-vars (append set-vars dyn-additions))) + (let + ((binding-strs (map (fn (b) (let ((vname (first b)) (vval (nth b 1))) (if (some (fn (sv) (= sv vname)) set-vars) (str "let " vname " = ref (" vval ") in") (str "let " vname " = " vval " in")))) parsed)) + (body-str + (if + (= (len body) 1) + (ml-expr-inner (first body) body-set-vars) + (ml-emit-do body body-set-vars)))) (str "(" (join " " binding-strs) " " body-str ")")))))))) -;; ml-parse-bindings-full returns (name ocaml-expr is-fn?) triples -(define ml-is-fn-expr? - (fn (expr) - (and (list? expr) (not (empty? expr)) - (= (type-of (first expr)) "symbol") - (or (= (symbol-name (first expr)) "fn") - (= (symbol-name (first expr)) "lambda"))))) +(define + ml-is-fn-expr? + (fn + (expr) + (and + (list? expr) + (not (empty? expr)) + (= (type-of (first expr)) "symbol") + (or + (= (symbol-name (first expr)) "fn") + (= (symbol-name (first expr)) "lambda"))))) -(define ml-parse-bindings-full - (fn (bindings (set-vars :as list)) - (if (and (list? bindings) (not (empty? bindings))) - (if (list? (first bindings)) - ;; Scheme-style: ((name val) ...) - (map (fn (b) - (let ((vname (if (= (type-of (first b)) "symbol") - (symbol-name (first b)) - (str (first b))))) - (list (ml-mangle vname) (ml-expr-inner (nth b 1) set-vars) (ml-is-fn-expr? (nth b 1))))) +(define + ml-parse-bindings-full + (fn + (bindings (set-vars :as list)) + (if + (and (list? bindings) (not (empty? bindings))) + (if + (list? (first bindings)) + (map + (fn + (b) + (let + ((vname (if (= (type-of (first b)) "symbol") (symbol-name (first b)) (str (first b))))) + (list + (ml-mangle vname) + (ml-expr-inner (nth b 1) set-vars) + (ml-is-fn-expr? (nth b 1))))) bindings) - ;; Clojure-style: (name val name val ...) (ml-parse-clojure-bindings-full bindings 0 (list) set-vars)) (list)))) -(define ml-parse-clojure-bindings-full - (fn (bindings (i :as number) (result :as list) (set-vars :as list)) - (if (>= i (- (len bindings) 1)) +(define + ml-parse-clojure-bindings-full + (fn + (bindings (i :as number) (result :as list) (set-vars :as list)) + (if + (>= i (- (len bindings) 1)) result - (let ((vname (if (= (type-of (nth bindings i)) "symbol") - (symbol-name (nth bindings i)) - (str (nth bindings i)))) - (val-expr (nth bindings (+ i 1)))) - (ml-parse-clojure-bindings-full bindings (+ i 2) - (append result (list (ml-mangle vname) (ml-expr-inner val-expr set-vars) (ml-is-fn-expr? val-expr))) + (let + ((vname (if (= (type-of (nth bindings i)) "symbol") (symbol-name (nth bindings i)) (str (nth bindings i)))) + (val-expr (nth bindings (+ i 1)))) + (ml-parse-clojure-bindings-full + bindings + (+ i 2) + (append + result + (list + (ml-mangle vname) + (ml-expr-inner val-expr set-vars) + (ml-is-fn-expr? val-expr))) set-vars))))) -(define ml-parse-bindings - (fn (bindings (set-vars :as list)) - (if (and (list? bindings) (not (empty? bindings))) - (if (list? (first bindings)) - ;; Scheme-style: ((name val) ...) - (map (fn (b) - (let ((vname (if (= (type-of (first b)) "symbol") - (symbol-name (first b)) - (str (first b))))) - (list (ml-mangle vname) (ml-expr-inner (nth b 1) set-vars)))) +(define + ml-parse-bindings + (fn + (bindings (set-vars :as list)) + (if + (and (list? bindings) (not (empty? bindings))) + (if + (list? (first bindings)) + (map + (fn + (b) + (let + ((vname (if (= (type-of (first b)) "symbol") (symbol-name (first b)) (str (first b))))) + (list (ml-mangle vname) (ml-expr-inner (nth b 1) set-vars)))) bindings) - ;; Clojure-style: (name val name val ...) (ml-parse-clojure-bindings bindings 0 (list) set-vars)) (list)))) -(define ml-parse-clojure-bindings - (fn (bindings (i :as number) (result :as list) (set-vars :as list)) - (if (>= i (- (len bindings) 1)) +(define + ml-parse-clojure-bindings + (fn + (bindings (i :as number) (result :as list) (set-vars :as list)) + (if + (>= i (- (len bindings) 1)) result - (let ((vname (if (= (type-of (nth bindings i)) "symbol") - (symbol-name (nth bindings i)) - (str (nth bindings i))))) - (ml-parse-clojure-bindings bindings (+ i 2) - (append result (list (ml-mangle vname) (ml-expr-inner (nth bindings (+ i 1)) set-vars))) + (let + ((vname (if (= (type-of (nth bindings i)) "symbol") (symbol-name (nth bindings i)) (str (nth bindings i))))) + (ml-parse-clojure-bindings + bindings + (+ i 2) + (append + result + (list + (ml-mangle vname) + (ml-expr-inner (nth bindings (+ i 1)) set-vars))) set-vars))))) +(define + ml-emit-when + (fn + (expr (set-vars :as list)) + (let + ((cond-e (ml-expr-inner (nth expr 1) set-vars)) + (body-parts (rest (rest expr)))) + (if + (= (len body-parts) 1) + (str + "(if sx_truthy (" + cond-e + ") then " + (ml-expr-inner (first body-parts) set-vars) + " else Nil)") + (str + "(if sx_truthy (" + cond-e + ") then " + (ml-emit-do body-parts set-vars) + " else Nil)"))))) -;; -------------------------------------------------------------------------- -;; when -;; -------------------------------------------------------------------------- - -(define ml-emit-when - (fn (expr (set-vars :as list)) - (let ((cond-e (ml-expr-inner (nth expr 1) set-vars)) - (body-parts (rest (rest expr)))) - (if (= (len body-parts) 1) - (str "(if sx_truthy (" cond-e ") then " (ml-expr-inner (first body-parts) set-vars) " else Nil)") - (str "(if sx_truthy (" cond-e ") then " (ml-emit-do body-parts set-vars) " else Nil)"))))) - - -;; -------------------------------------------------------------------------- -;; cond → chained if/then/else -;; -------------------------------------------------------------------------- - -(define ml-emit-cond - (fn ((clauses :as list) (set-vars :as list)) - (if (empty? clauses) +(define + ml-emit-cond + (fn + ((clauses :as list) (set-vars :as list)) + (if + (empty? clauses) "Nil" - (let ((is-scheme (and - (every? (fn (c) (and (list? c) (= (len c) 2))) clauses) - (not (some (fn (c) (= (type-of c) "keyword")) clauses))))) - (if is-scheme + (let + ((is-scheme (and (every? (fn (c) (and (list? c) (= (len c) 2))) clauses) (not (some (fn (c) (= (type-of c) "keyword")) clauses))))) + (if + is-scheme (ml-cond-scheme clauses set-vars) (ml-cond-clojure clauses set-vars)))))) -(define ml-is-else? - (fn (test) - (or (and (= (type-of test) "symbol") - (or (= (symbol-name test) "else") (= (symbol-name test) ":else"))) - (and (= (type-of test) "keyword") (= (keyword-name test) "else"))))) +(define + ml-is-else? + (fn + (test) + (or + (and + (= (type-of test) "symbol") + (or + (= (symbol-name test) "else") + (= (symbol-name test) ":else") + (= (symbol-name test) "_"))) + (and (= (type-of test) "keyword") (= (keyword-name test) "else"))))) -(define ml-cond-scheme - (fn ((clauses :as list) (set-vars :as list)) - (if (empty? clauses) +(define + ml-cond-scheme + (fn + ((clauses :as list) (set-vars :as list)) + (if + (empty? clauses) "Nil" - (let ((clause (first clauses)) - (test (first clause)) - (body (nth clause 1))) - (if (ml-is-else? test) + (let + ((clause (first clauses)) + (test (first clause)) + (body (nth clause 1))) + (if + (ml-is-else? test) (ml-expr-inner body set-vars) - (str "(if sx_truthy (" (ml-expr-inner test set-vars) ") then " - (ml-expr-inner body set-vars) - " else " (ml-cond-scheme (rest clauses) set-vars) ")")))))) + (str + "(if sx_truthy (" + (ml-expr-inner test set-vars) + ") then " + (ml-expr-inner body set-vars) + " else " + (ml-cond-scheme (rest clauses) set-vars) + ")")))))) -(define ml-cond-clojure - (fn ((clauses :as list) (set-vars :as list)) - (if (< (len clauses) 2) +(define + ml-cond-clojure + (fn + ((clauses :as list) (set-vars :as list)) + (if + (< (len clauses) 2) "Nil" - (let ((test (first clauses)) - (body (nth clauses 1))) - (if (ml-is-else? test) + (let + ((test (first clauses)) (body (nth clauses 1))) + (if + (ml-is-else? test) (ml-expr-inner body set-vars) - (str "(if sx_truthy (" (ml-expr-inner test set-vars) ") then " - (ml-expr-inner body set-vars) - " else " (ml-cond-clojure (rest (rest clauses)) set-vars) ")")))))) + (str + "(if sx_truthy (" + (ml-expr-inner test set-vars) + ") then " + (ml-expr-inner body set-vars) + " else " + (ml-cond-clojure (rest (rest clauses)) set-vars) + ")")))))) +(define + ml-emit-case + (fn + ((args :as list) (set-vars :as list)) + (let + ((match-expr (ml-expr-inner (first args) set-vars)) + (clauses (rest args))) + (str + "(let _match_val = " + match-expr + " in " + (ml-case-chain clauses set-vars) + ")")))) -;; -------------------------------------------------------------------------- -;; case → match ... with -;; -------------------------------------------------------------------------- - -(define ml-emit-case - (fn ((args :as list) (set-vars :as list)) - (let ((match-expr (ml-expr-inner (first args) set-vars)) - (clauses (rest args))) - (str "(let _match_val = " match-expr " in " - (ml-case-chain clauses set-vars) ")")))) - -(define ml-case-chain - (fn ((clauses :as list) (set-vars :as list)) - (if (< (len clauses) 2) +(define + ml-case-chain + (fn + ((clauses :as list) (set-vars :as list)) + (if + (empty? clauses) "Nil" - (let ((test (first clauses)) - (body (nth clauses 1))) - (if (ml-is-else? test) - (ml-expr-inner body set-vars) - (str "(if _match_val = " (ml-expr-inner test set-vars) - " then " (ml-expr-inner body set-vars) - " else " (ml-case-chain (rest (rest clauses)) set-vars) ")")))))) + (let + ((clause (first clauses))) + (if + (list? clause) + (let + ((test (first clause)) (body (nth clause 1))) + (if + (ml-is-else? test) + (ml-expr-inner body set-vars) + (str + "(if sx_truthy ((prim_call \"=\" [_match_val; " + (ml-expr-inner test set-vars) + "])) then " + (ml-expr-inner body set-vars) + " else " + (ml-case-chain (rest clauses) set-vars) + ")"))) + (if + (< (len clauses) 2) + "Nil" + (let + ((test (first clauses)) (body (nth clauses 1))) + (if + (ml-is-else? test) + (ml-expr-inner body set-vars) + (str + "(if _match_val = " + (ml-expr-inner test set-vars) + " then " + (ml-expr-inner body set-vars) + " else " + (ml-case-chain (rest (rest clauses)) set-vars) + ")"))))))))) - -;; -------------------------------------------------------------------------- -;; and/or → short-circuit -;; -------------------------------------------------------------------------- - -(define ml-emit-and - (fn ((args :as list) (set-vars :as list)) - (if (= (len args) 1) +(define + ml-emit-and + (fn + ((args :as list) (set-vars :as list)) + (if + (= (len args) 1) (ml-expr-inner (first args) set-vars) - (let ((parts (map (fn (x) (ml-expr-inner x set-vars)) args))) + (let + ((parts (map (fn (x) (ml-expr-inner x set-vars)) args))) (ml-and-chain parts))))) -(define ml-and-chain - (fn ((parts :as list)) - (if (= (len parts) 1) +(define + ml-and-chain + (fn + ((parts :as list)) + (if + (= (len parts) 1) (first parts) - (str "(let _and = " (first parts) " in if not (sx_truthy _and) then _and else " (ml-and-chain (rest parts)) ")")))) + (str + "(let _and = " + (first parts) + " in if not (sx_truthy _and) then _and else " + (ml-and-chain (rest parts)) + ")")))) -(define ml-emit-or - (fn ((args :as list) (set-vars :as list)) - (if (= (len args) 1) +(define + ml-emit-or + (fn + ((args :as list) (set-vars :as list)) + (if + (= (len args) 1) (ml-expr-inner (first args) set-vars) - (let ((parts (map (fn (x) (ml-expr-inner x set-vars)) args))) + (let + ((parts (map (fn (x) (ml-expr-inner x set-vars)) args))) (ml-or-chain parts))))) -(define ml-or-chain - (fn ((parts :as list)) - (if (= (len parts) 1) +(define + ml-or-chain + (fn + ((parts :as list)) + (if + (= (len parts) 1) (first parts) - (str "(let _or = " (first parts) " in if sx_truthy _or then _or else " (ml-or-chain (rest parts)) ")")))) + (str + "(let _or = " + (first parts) + " in if sx_truthy _or then _or else " + (ml-or-chain (rest parts)) + ")")))) - -;; -------------------------------------------------------------------------- -;; do/begin → sequencing -;; -------------------------------------------------------------------------- - -(define ml-emit-do - (fn ((args :as list) (set-vars :as list)) - (if (= (len args) 1) +(define + ml-emit-do + (fn + ((args :as list) (set-vars :as list)) + (if + (= (len args) 1) (ml-expr-inner (first args) set-vars) - ;; Check for defines in the block — emit as let...in chain (ml-emit-do-chain args 0 set-vars)))) -(define ml-is-define? - (fn (expr) - (and (list? expr) (not (empty? expr)) - (= (type-of (first expr)) "symbol") - (= (symbol-name (first expr)) "define")))) +(define + ml-is-define? + (fn + (expr) + (and + (list? expr) + (not (empty? expr)) + (= (type-of (first expr)) "symbol") + (= (symbol-name (first expr)) "define")))) -(define ml-emit-do-chain - (fn ((args :as list) (i :as number) (set-vars :as list)) - (if (>= i (len args)) +(define + ml-emit-do-chain + (fn + ((args :as list) (i :as number) (set-vars :as list)) + (if + (>= i (len args)) "Nil" - (let ((expr (nth args i)) - (is-last (= i (- (len args) 1)))) - (if (ml-is-define? expr) - ;; define inside do — emit as let...in - (let ((name (if (= (type-of (nth expr 1)) "symbol") - (symbol-name (nth expr 1)) - (str (nth expr 1)))) - (val-expr (nth expr 2))) - (let ((ml-name (ml-mangle name)) - (is-fn (and (list? val-expr) - (not (empty? val-expr)) - (= (type-of (first val-expr)) "symbol") - (or (= (symbol-name (first val-expr)) "fn") - (= (symbol-name (first val-expr)) "lambda")))) - (is-recursive (ml-is-self-recursive? name val-expr))) - (let ((rec-kw (if is-recursive "rec " "")) - ;; Recursive fns must be bare OCaml functions (called directly) - (val-str (if (and is-fn is-recursive) - (ml-emit-fn-bare val-expr set-vars) - (ml-expr-inner val-expr set-vars))) - (rest-str (ml-emit-do-chain args (+ i 1) set-vars))) + (let + ((expr (nth args i)) (is-last (= i (- (len args) 1)))) + (if + (ml-is-define? expr) + (let + ((name (if (= (type-of (nth expr 1)) "symbol") (symbol-name (nth expr 1)) (str (nth expr 1)))) + (val-expr (nth expr 2))) + (let + ((ml-name (ml-mangle name)) + (is-fn + (and + (list? val-expr) + (not (empty? val-expr)) + (= (type-of (first val-expr)) "symbol") + (or + (= (symbol-name (first val-expr)) "fn") + (= (symbol-name (first val-expr)) "lambda")))) + (is-recursive (ml-is-self-recursive? name val-expr))) + (let + ((rec-kw (if is-recursive "rec " "")) + (val-str + (if + (and is-fn is-recursive) + (ml-emit-fn-bare val-expr set-vars) + (ml-expr-inner val-expr set-vars))) + (rest-str (ml-emit-do-chain args (+ i 1) set-vars))) (str "(let " rec-kw ml-name " = " val-str " in " rest-str ")")))) - ;; Non-define expression - (if is-last + (if + is-last (ml-expr-inner expr set-vars) - (str "(let () = ignore (" (ml-expr-inner expr set-vars) ") in " - (ml-emit-do-chain args (+ i 1) set-vars) ")"))))))) + (str + "(let () = ignore (" + (ml-expr-inner expr set-vars) + ") in " + (ml-emit-do-chain args (+ i 1) set-vars) + ")"))))))) +(define + ml-is-inline-fn? + (fn + (expr) + (and + (list? expr) + (not (empty? expr)) + (= (type-of (first expr)) "symbol") + (or + (= (symbol-name (first expr)) "fn") + (= (symbol-name (first expr)) "lambda"))))) -;; -------------------------------------------------------------------------- -;; Higher-order form helpers — detect inline lambdas for direct OCaml calls -;; -------------------------------------------------------------------------- +(define + ml-emit-ho-form + (fn + ((ocaml-fn :as string) + (wrap-pre :as string) + (wrap-post :as string) + (result-wrap :as string) + (args :as list) + (set-vars :as list)) + (let + ((fn-arg (first args)) + (coll-arg (nth args 1)) + (needs-bool + (or + (= ocaml-fn "List.filter") + (= ocaml-fn "List.exists") + (= ocaml-fn "List.for_all")))) + (if + (ml-is-inline-fn? fn-arg) + (let + ((params (nth fn-arg 1)) + (body (rest (rest fn-arg))) + (param-strs (ml-collect-params params))) + (let + ((param-str (if (empty? param-strs) "_" (first param-strs))) + (body-str + (if + (= (len body) 1) + (ml-expr-inner (first body) set-vars) + (ml-emit-do body set-vars)))) + (let + ((wrapped-body (if needs-bool (str "sx_truthy (" body-str ")") body-str))) + (str + "(" + result-wrap + " (" + ocaml-fn + " (fun " + param-str + " -> " + wrapped-body + ") (sx_to_list " + (ml-expr-inner coll-arg set-vars) + ")))")))) + (let + ((fn-str (ml-expr-inner fn-arg set-vars))) + (if + needs-bool + (str + "(" + result-wrap + " (" + ocaml-fn + " (fun _x -> sx_truthy (cek_call " + fn-str + " (List [_x])))" + " (sx_to_list " + (ml-expr-inner coll-arg set-vars) + ")))") + (str + "(" + result-wrap + " (" + ocaml-fn + " (fun _x -> cek_call " + fn-str + " (List [_x]))" + " (sx_to_list " + (ml-expr-inner coll-arg set-vars) + ")))"))))))) -(define ml-is-inline-fn? - (fn (expr) - (and (list? expr) (not (empty? expr)) - (= (type-of (first expr)) "symbol") - (or (= (symbol-name (first expr)) "fn") - (= (symbol-name (first expr)) "lambda"))))) +(define + ml-emit-ho-indexed + (fn + ((args :as list) (set-vars :as list)) + (let + ((fn-arg (first args)) (coll-arg (nth args 1))) + (if + (ml-is-inline-fn? fn-arg) + (let + ((params (nth fn-arg 1)) + (body (rest (rest fn-arg))) + (param-strs (ml-collect-params params))) + (let + ((i-param (if (>= (len param-strs) 1) (first param-strs) "_i")) + (v-param + (if (>= (len param-strs) 2) (nth param-strs 1) "_v")) + (body-str + (if + (= (len body) 1) + (ml-expr-inner (first body) set-vars) + (ml-emit-do body set-vars)))) + (str + "(List (List.mapi (fun " + i-param + " " + v-param + " -> let " + i-param + " = Number (float_of_int " + i-param + ") in " + body-str + ") (sx_to_list " + (ml-expr-inner coll-arg set-vars) + ")))"))) + (str + "(List (List.mapi (fun _i _x -> cek_call " + (ml-expr-inner fn-arg set-vars) + " (List [Number (float_of_int _i); _x])) (sx_to_list " + (ml-expr-inner coll-arg set-vars) + ")))"))))) -(define ml-emit-ho-form - (fn ((ocaml-fn :as string) (wrap-pre :as string) (wrap-post :as string) - (result-wrap :as string) (args :as list) (set-vars :as list)) - (let ((fn-arg (first args)) - (coll-arg (nth args 1)) - ;; Detect if the OCaml HOF needs bool (filter, exists, for_all) - (needs-bool (or (= ocaml-fn "List.filter") - (= ocaml-fn "List.exists") - (= ocaml-fn "List.for_all")))) - (if (ml-is-inline-fn? fn-arg) - ;; Inline lambda — call directly, no sx_call - (let ((params (nth fn-arg 1)) - (body (rest (rest fn-arg))) - (param-strs (ml-collect-params params))) - (let ((param-str (if (empty? param-strs) "_" (first param-strs))) - (body-str (if (= (len body) 1) - (ml-expr-inner (first body) set-vars) - (ml-emit-do body set-vars)))) - (let ((wrapped-body (if needs-bool - (str "sx_truthy (" body-str ")") - body-str))) - (str "(" result-wrap " (" ocaml-fn " (fun " param-str " -> " wrapped-body - ") (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))) - ;; Named function — dispatch via cek_call (fn may be NativeFn value) - (let ((fn-str (ml-expr-inner fn-arg set-vars))) - (if needs-bool - (str "(" result-wrap " (" ocaml-fn " (fun _x -> sx_truthy (cek_call " fn-str " (List [_x])))" - " (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))") - (str "(" result-wrap " (" ocaml-fn " (fun _x -> cek_call " fn-str " (List [_x]))" - " (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))))))) +(define + ml-emit-reduce + (fn + ((args :as list) (set-vars :as list)) + (let + ((fn-arg (first args)) + (init-arg (nth args 1)) + (coll-arg (nth args 2))) + (if + (ml-is-inline-fn? fn-arg) + (let + ((params (nth fn-arg 1)) + (body (rest (rest fn-arg))) + (param-strs (ml-collect-params params))) + (let + ((raw-acc (if (>= (len param-strs) 1) (first param-strs) "_acc")) + (x-param + (if (>= (len param-strs) 2) (nth param-strs 1) "_x")) + (body-str + (if + (= (len body) 1) + (ml-expr-inner (first body) set-vars) + (ml-emit-do body set-vars))) + (acc-param + (if + (string-contains? body-str raw-acc) + raw-acc + (if (starts-with? raw-acc "_") raw-acc (str "_" raw-acc))))) + (str + "(List.fold_left (fun " + acc-param + " " + x-param + " -> " + body-str + ") " + (ml-expr-inner init-arg set-vars) + " (sx_to_list " + (ml-expr-inner coll-arg set-vars) + "))"))) + (str + "(List.fold_left (fun _acc _x -> cek_call " + (ml-expr-inner fn-arg set-vars) + " (List [_acc; _x])) " + (ml-expr-inner init-arg set-vars) + " (sx_to_list " + (ml-expr-inner coll-arg set-vars) + "))"))))) -(define ml-emit-ho-indexed - (fn ((args :as list) (set-vars :as list)) - (let ((fn-arg (first args)) - (coll-arg (nth args 1))) - (if (ml-is-inline-fn? fn-arg) - (let ((params (nth fn-arg 1)) - (body (rest (rest fn-arg))) - (param-strs (ml-collect-params params))) - (let ((i-param (if (>= (len param-strs) 1) (first param-strs) "_i")) - (v-param (if (>= (len param-strs) 2) (nth param-strs 1) "_v")) - (body-str (if (= (len body) 1) - (ml-expr-inner (first body) set-vars) - (ml-emit-do body set-vars)))) - (str "(List (List.mapi (fun " i-param " " v-param " -> let " i-param " = Number (float_of_int " i-param ") in " body-str - ") (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))) - (str "(List (List.mapi (fun _i _x -> cek_call " (ml-expr-inner fn-arg set-vars) - " (List [Number (float_of_int _i); _x])) (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))))) +(define + ml-emit-for-each + (fn + ((args :as list) (set-vars :as list)) + (let + ((fn-arg (first args)) (coll-arg (nth args 1))) + (if + (ml-is-inline-fn? fn-arg) + (let + ((params (nth fn-arg 1)) + (body (rest (rest fn-arg))) + (param-strs (ml-collect-params params))) + (let + ((param-str (if (empty? param-strs) "_" (first param-strs))) + (body-str + (if + (= (len body) 1) + (ml-expr-inner (first body) set-vars) + (ml-emit-do body set-vars)))) + (str + "(List.iter (fun " + param-str + " -> ignore (" + body-str + ")) (sx_to_list " + (ml-expr-inner coll-arg set-vars) + "); Nil)"))) + (str + "(List.iter (fun _x -> ignore (cek_call " + (ml-expr-inner fn-arg set-vars) + " (List [_x]))) (sx_to_list " + (ml-expr-inner coll-arg set-vars) + "); Nil)"))))) -(define ml-emit-reduce - (fn ((args :as list) (set-vars :as list)) - (let ((fn-arg (first args)) - (init-arg (nth args 1)) - (coll-arg (nth args 2))) - (if (ml-is-inline-fn? fn-arg) - (let ((params (nth fn-arg 1)) - (body (rest (rest fn-arg))) - (param-strs (ml-collect-params params))) - (let ((raw-acc (if (>= (len param-strs) 1) (first param-strs) "_acc")) - (x-param (if (>= (len param-strs) 2) (nth param-strs 1) "_x")) - (body-str (if (= (len body) 1) - (ml-expr-inner (first body) set-vars) - (ml-emit-do body set-vars))) - ;; Prefix acc with _ if unused in body to avoid OCaml warning - (acc-param (if (string-contains? body-str raw-acc) raw-acc - (if (starts-with? raw-acc "_") raw-acc - (str "_" raw-acc))))) - (str "(List.fold_left (fun " acc-param " " x-param " -> " body-str ") " - (ml-expr-inner init-arg set-vars) " (sx_to_list " (ml-expr-inner coll-arg set-vars) "))"))) - (str "(List.fold_left (fun _acc _x -> cek_call " (ml-expr-inner fn-arg set-vars) - " (List [_acc; _x])) " (ml-expr-inner init-arg set-vars) - " (sx_to_list " (ml-expr-inner coll-arg set-vars) "))"))))) +(define + ml-emit-map-dict + (fn + ((args :as list) (set-vars :as list)) + (let + ((fn-arg (first args)) (dict-arg (nth args 1))) + (if + (ml-is-inline-fn? fn-arg) + (let + ((params (nth fn-arg 1)) + (body (rest (rest fn-arg))) + (param-strs (ml-collect-params params))) + (let + ((k-param (if (>= (len param-strs) 1) (first param-strs) "_k")) + (v-param + (if (>= (len param-strs) 2) (nth param-strs 1) "_v")) + (body-str + (if + (= (len body) 1) + (ml-expr-inner (first body) set-vars) + (ml-emit-do body set-vars)))) + (str + "(match " + (ml-expr-inner dict-arg set-vars) + " with Dict _tbl -> " + "let _r = Hashtbl.create (Hashtbl.length _tbl) in " + "Hashtbl.iter (fun " + k-param + " " + v-param + " -> " + "let " + k-param + " = String " + k-param + " in " + "Hashtbl.replace _r (value_to_str " + k-param + ") (" + body-str + ")) _tbl; " + "Dict _r | _ -> raise (Eval_error \"map-dict: expected dict\"))"))) + (let + ((fn-str (ml-expr-inner fn-arg set-vars))) + (str + "(match " + (ml-expr-inner dict-arg set-vars) + " with Dict _tbl -> " + "let _r = Hashtbl.create (Hashtbl.length _tbl) in " + "Hashtbl.iter (fun _k _v -> " + "Hashtbl.replace _r _k (cek_call " + fn-str + " (List [String _k; _v]))) _tbl; " + "Dict _r | _ -> raise (Eval_error \"map-dict: expected dict\"))")))))) - -;; -------------------------------------------------------------------------- -;; for-each -;; -------------------------------------------------------------------------- - -(define ml-emit-for-each - (fn ((args :as list) (set-vars :as list)) - (let ((fn-arg (first args)) - (coll-arg (nth args 1))) - (if (ml-is-inline-fn? fn-arg) - (let ((params (nth fn-arg 1)) - (body (rest (rest fn-arg))) - (param-strs (ml-collect-params params))) - (let ((param-str (if (empty? param-strs) "_" (first param-strs))) - (body-str (if (= (len body) 1) - (ml-expr-inner (first body) set-vars) - (ml-emit-do body set-vars)))) - (str "(List.iter (fun " param-str " -> ignore (" body-str - ")) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)"))) - (str "(List.iter (fun _x -> ignore (cek_call " (ml-expr-inner fn-arg set-vars) - " (List [_x]))) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)"))))) - - -;; -------------------------------------------------------------------------- -;; map-dict -;; -------------------------------------------------------------------------- - -(define ml-emit-map-dict - (fn ((args :as list) (set-vars :as list)) - (let ((fn-arg (first args)) - (dict-arg (nth args 1))) - (if (ml-is-inline-fn? fn-arg) - (let ((params (nth fn-arg 1)) - (body (rest (rest fn-arg))) - (param-strs (ml-collect-params params))) - (let ((k-param (if (>= (len param-strs) 1) (first param-strs) "_k")) - (v-param (if (>= (len param-strs) 2) (nth param-strs 1) "_v")) - (body-str (if (= (len body) 1) - (ml-expr-inner (first body) set-vars) - (ml-emit-do body set-vars)))) - (str "(match " (ml-expr-inner dict-arg set-vars) " with Dict _tbl -> " - "let _r = Hashtbl.create (Hashtbl.length _tbl) in " - "Hashtbl.iter (fun " k-param " " v-param " -> " - "let " k-param " = String " k-param " in " - "Hashtbl.replace _r (value_to_str " k-param ") (" body-str ")) _tbl; " - "Dict _r | _ -> raise (Eval_error \"map-dict: expected dict\"))"))) - (let ((fn-str (ml-expr-inner fn-arg set-vars))) - (str "(match " (ml-expr-inner dict-arg set-vars) " with Dict _tbl -> " - "let _r = Hashtbl.create (Hashtbl.length _tbl) in " - "Hashtbl.iter (fun _k _v -> " - "Hashtbl.replace _r _k (cek_call " fn-str " (List [String _k; _v]))) _tbl; " - "Dict _r | _ -> raise (Eval_error \"map-dict: expected dict\"))")))))) - - -;; -------------------------------------------------------------------------- -;; dict call -;; -------------------------------------------------------------------------- - -(define ml-emit-dict-call - (fn ((pairs :as list) (set-vars :as list)) - (let ((n (len pairs))) - (if (= n 0) +(define + ml-emit-dict-call + (fn + ((pairs :as list) (set-vars :as list)) + (let + ((n (len pairs))) + (if + (= n 0) "(Dict (Hashtbl.create 0))" - (str "(let _d = Hashtbl.create " (str (round (/ n 2))) - " in " (ml-dict-pairs pairs 0 set-vars) " Dict _d)"))))) + (str + "(let _d = Hashtbl.create " + (str (round (/ n 2))) + " in " + (ml-dict-pairs pairs 0 set-vars) + " Dict _d)"))))) -(define ml-dict-pairs - (fn ((pairs :as list) (i :as number) (set-vars :as list)) - (if (>= i (- (len pairs) 1)) +(define + ml-dict-pairs + (fn + ((pairs :as list) (i :as number) (set-vars :as list)) + (if + (>= i (- (len pairs) 1)) "" - (let ((key (nth pairs i)) - (val (nth pairs (+ i 1)))) - (let ((key-str (if (= (type-of key) "keyword") - (ml-quote-string (keyword-name key)) - (str "(value_to_str " (ml-expr-inner key set-vars) ")"))) - (val-str (ml-expr-inner val set-vars))) - (str "Hashtbl.replace _d " key-str " " val-str "; " - (ml-dict-pairs pairs (+ i 2) set-vars))))))) + (let + ((key (nth pairs i)) (val (nth pairs (+ i 1)))) + (let + ((key-str (if (= (type-of key) "keyword") (ml-quote-string (keyword-name key)) (str "(value_to_str " (ml-expr-inner key set-vars) ")"))) + (val-str (ml-expr-inner val set-vars))) + (str + "Hashtbl.replace _d " + key-str + " " + val-str + "; " + (ml-dict-pairs pairs (+ i 2) set-vars))))))) - -;; -------------------------------------------------------------------------- -;; quote → OCaml AST literals -;; -------------------------------------------------------------------------- - -(define ml-emit-quote - (fn (expr) +(define + ml-emit-quote + (fn + (expr) (cond (= (type-of expr) "boolean") - (if expr "(Bool true)" "(Bool false)") - (number? expr) (str "(Number " (str expr) ")") - (string? expr) (str "(String " (ml-quote-string expr) ")") - (nil? expr) "Nil" + (if expr "(Bool true)" "(Bool false)") + (number? expr) + (str "(Number " (str expr) ")") + (string? expr) + (str "(String " (ml-quote-string expr) ")") + (nil? expr) + "Nil" (= (type-of expr) "symbol") - (str "(Symbol " (ml-quote-string (symbol-name expr)) ")") + (str "(Symbol " (ml-quote-string (symbol-name expr)) ")") (= (type-of expr) "keyword") - (str "(Keyword " (ml-quote-string (keyword-name expr)) ")") + (str "(Keyword " (ml-quote-string (keyword-name expr)) ")") (list? expr) - (str "(List [" (join "; " (map ml-emit-quote expr)) "])") + (str "(List [" (join "; " (map ml-emit-quote expr)) "])") :else (str "(* quote fallback *) " (str expr))))) - -;; -------------------------------------------------------------------------- -;; Top-level define -;; -------------------------------------------------------------------------- - -(define ml-emit-define - (fn (expr) - (let ((name (if (= (type-of (nth expr 1)) "symbol") - (symbol-name (nth expr 1)) - (str (nth expr 1)))) - (val-expr (nth expr 2))) - (let ((ml-name (ml-mangle name)) - (is-fn (and (list? val-expr) - (not (empty? val-expr)) - (= (type-of (first val-expr)) "symbol") - (or (= (symbol-name (first val-expr)) "fn") - (= (symbol-name (first val-expr)) "lambda")))) - (is-recursive (ml-is-self-recursive? name val-expr))) - (let ((rec-kw (if is-recursive "rec " ""))) - (if is-fn - ;; Function define — emit as let [rec] name params = body - (let ((params (nth val-expr 1)) - (body (rest (rest val-expr))) - (param-strs (ml-collect-params params)) - (set-targets (ml-find-set-targets body)) - (let-bound (ml-find-let-bound-names body))) - (let ((params-str (if (empty? param-strs) "()" (join " " param-strs))) - (all-set-vars set-targets) - (needs-ref (filter (fn (v) (not (some (fn (lb) (= lb v)) let-bound))) set-targets))) - (if (empty? set-targets) - (if (= (len body) 1) - (str "let " rec-kw ml-name " " params-str " =\n " - (ml-expr-inner (first body) all-set-vars) "\n") - (str "let " rec-kw ml-name " " params-str " =\n " - (ml-emit-do body all-set-vars) "\n")) - ;; Has set! targets — only pre-declare refs for non-let-bound - (let ((ref-decls (if (empty? needs-ref) "" - (str (join " " (map (fn (v) (str "let " v " = ref Nil in")) needs-ref)) " "))) - (body-str (if (= (len body) 1) - (ml-expr-inner (first body) all-set-vars) - (ml-emit-do body all-set-vars)))) - (str "let " rec-kw ml-name " " params-str " =\n " - ref-decls body-str "\n"))))) - ;; Non-function define - (str "let " ml-name " =\n " (ml-expr val-expr) "\n"))))))) - - -;; -------------------------------------------------------------------------- -;; File translation: process a list of (name, define-expr) pairs -;; -------------------------------------------------------------------------- - -;; ml-translate-file emits all defines as a single let rec ... and ... block. -;; This handles forward references between evaluator functions — OCaml's -;; let rec allows mutual recursion between all and-joined definitions. -(define ml-translate-file - (fn ((defines :as list)) - (let ((parts (map (fn (pair) - (let ((name (first pair)) - (expr (nth pair 1))) - (str "(* " name " *)\n" (ml-emit-define-body expr)))) - defines))) - ;; Join with "and" — first one uses "let rec", rest use "and" - ;; Each part is "(* name *)\nlet rec name ..." — replace the "let rec" on second line - (if (empty? parts) - "" - (str (first parts) "\n" (join "\n" (map (fn (p) - ;; Find first newline, then replace "let rec " after it - (let ((nl-idx (index-of p "\n"))) - (if (and (number? nl-idx) (>= nl-idx 0)) - (let ((before (slice p 0 (+ nl-idx 1))) - (after (slice p (+ nl-idx 1)))) - (if (starts-with? after "let rec ") - (str before "and " (slice after 8)) - p)) - ;; No newline — try direct replacement - (if (starts-with? p "let rec ") - (str "and " (slice p 8)) - p)))) - (rest parts)))))))) - -;; ml-emit-define-body — like ml-emit-define but always emits as let [rec] -(define ml-emit-define-body - (fn (expr) - (let ((name (if (= (type-of (nth expr 1)) "symbol") - (symbol-name (nth expr 1)) - (str (nth expr 1)))) - (val-expr (nth expr 2))) - (let ((ml-name (ml-mangle name)) - (is-fn (and (list? val-expr) - (not (empty? val-expr)) - (= (type-of (first val-expr)) "symbol") - (or (= (symbol-name (first val-expr)) "fn") - (= (symbol-name (first val-expr)) "lambda"))))) - (if is-fn - ;; Function define - (let ((params (nth val-expr 1)) +(define + ml-emit-define + (fn + (expr) + (let + ((name (if (= (type-of (nth expr 1)) "symbol") (symbol-name (nth expr 1)) (str (nth expr 1)))) + (val-expr (nth expr 2))) + (let + ((ml-name (ml-mangle name)) + (is-fn + (and + (list? val-expr) + (not (empty? val-expr)) + (= (type-of (first val-expr)) "symbol") + (or + (= (symbol-name (first val-expr)) "fn") + (= (symbol-name (first val-expr)) "lambda")))) + (is-recursive (ml-is-self-recursive? name val-expr))) + (let + ((rec-kw (if is-recursive "rec " ""))) + (if + is-fn + (let + ((params (nth val-expr 1)) (body (rest (rest val-expr))) (param-strs (ml-collect-params params)) (set-targets (ml-find-set-targets body)) (let-bound (ml-find-let-bound-names body))) - (let ((params-str (if (empty? param-strs) "()" (join " " param-strs))) - (needs-ref (filter (fn (v) (not (some (fn (lb) (= lb v)) let-bound))) set-targets))) - (if (empty? set-targets) - (if (= (len body) 1) - (str "let rec " ml-name " " params-str " =\n " - (ml-expr-inner (first body) set-targets) "\n") - (str "let rec " ml-name " " params-str " =\n " - (ml-emit-do body set-targets) "\n")) - (let ((ref-decls (if (empty? needs-ref) "" - (str (join " " (map (fn (v) (str "let " v " = ref Nil in")) needs-ref)) " "))) - (body-str (if (= (len body) 1) - (ml-expr-inner (first body) set-targets) - (ml-emit-do body set-targets)))) - (str "let rec " ml-name " " params-str " =\n " - ref-decls body-str "\n"))))) - ;; Non-function define + (let + ((params-str (if (empty? param-strs) "()" (join " " param-strs))) + (all-set-vars set-targets) + (needs-ref + (filter + (fn (v) (not (some (fn (lb) (= lb v)) let-bound))) + set-targets))) + (if + (empty? set-targets) + (if + (= (len body) 1) + (str + "let " + rec-kw + ml-name + " " + params-str + " =\n " + (ml-expr-inner (first body) all-set-vars) + "\n") + (str + "let " + rec-kw + ml-name + " " + params-str + " =\n " + (ml-emit-do body all-set-vars) + "\n")) + (let + ((ref-decls (if (empty? needs-ref) "" (str (join " " (map (fn (v) (str "let " v " = ref Nil in")) needs-ref)) " "))) + (body-str + (if + (= (len body) 1) + (ml-expr-inner (first body) all-set-vars) + (ml-emit-do body all-set-vars)))) + (str + "let " + rec-kw + ml-name + " " + params-str + " =\n " + ref-decls + body-str + "\n"))))) + (str "let " ml-name " =\n " (ml-expr val-expr) "\n"))))))) + +(define + ml-translate-file + (fn + ((defines :as list)) + (let + ((parts (map (fn (pair) (let ((name (first pair)) (expr (nth pair 1))) (str "(* " name " *)\n" (ml-emit-define-body expr)))) defines))) + (if + (empty? parts) + "" + (str + (first parts) + "\n" + (join + "\n" + (map + (fn + (p) + (let + ((nl-idx (index-of p "\n"))) + (if + (and (number? nl-idx) (>= nl-idx 0)) + (let + ((before (slice p 0 (+ nl-idx 1))) + (after (slice p (+ nl-idx 1)))) + (if + (starts-with? after "let rec ") + (str before "and " (slice after 8)) + p)) + (if + (starts-with? p "let rec ") + (str "and " (slice p 8)) + p)))) + (rest parts)))))))) + +(define + ml-emit-define-body + (fn + (expr) + (let + ((name (if (= (type-of (nth expr 1)) "symbol") (symbol-name (nth expr 1)) (str (nth expr 1)))) + (val-expr (nth expr 2))) + (let + ((ml-name (ml-mangle name)) + (is-fn + (and + (list? val-expr) + (not (empty? val-expr)) + (= (type-of (first val-expr)) "symbol") + (or + (= (symbol-name (first val-expr)) "fn") + (= (symbol-name (first val-expr)) "lambda"))))) + (if + is-fn + (let + ((params (nth val-expr 1)) + (body (rest (rest val-expr))) + (param-strs (ml-collect-params params)) + (set-targets (ml-find-set-targets body)) + (let-bound (ml-find-let-bound-names body))) + (let + ((params-str (if (empty? param-strs) "()" (join " " param-strs))) + (needs-ref + (filter + (fn (v) (not (some (fn (lb) (= lb v)) let-bound))) + set-targets))) + (if + (empty? set-targets) + (if + (= (len body) 1) + (str + "let rec " + ml-name + " " + params-str + " =\n " + (ml-expr-inner (first body) set-targets) + "\n") + (str + "let rec " + ml-name + " " + params-str + " =\n " + (ml-emit-do body set-targets) + "\n")) + (let + ((ref-decls (if (empty? needs-ref) "" (str (join " " (map (fn (v) (str "let " v " = ref Nil in")) needs-ref)) " "))) + (body-str + (if + (= (len body) 1) + (ml-expr-inner (first body) set-targets) + (ml-emit-do body set-targets)))) + (str + "let rec " + ml-name + " " + params-str + " =\n " + ref-decls + body-str + "\n"))))) (str "let rec " ml-name " =\n " (ml-expr val-expr) "\n")))))) diff --git a/spec/evaluator.sx b/spec/evaluator.sx index 2823bd62..9f0fd318 100644 --- a/spec/evaluator.sx +++ b/spec/evaluator.sx @@ -1,67 +1,49 @@ -;; Construct a CEK state: expression to evaluate, env, continuation (define make-cek-state (fn (control env kont) {:control control :env env :kont kont :value nil :phase "eval"})) -;; Construct a CEK value state: computation complete, result ready (define make-cek-value (fn (value env kont) {:control nil :env env :kont kont :value value :phase "continue"})) -;; True if state is a terminal value (no more steps needed) (define cek-terminal? (fn (state) (and (= (get state "phase") "continue") (empty? (get state "kont"))))) -;; Extract the control expression from a CEK state (define cek-control (fn (s) (get s "control"))) -;; Extract the environment from a CEK state (define cek-env (fn (s) (get s "env"))) -;; Extract the continuation stack from a CEK state (define cek-kont (fn (s) (get s "kont"))) -;; Return state phase: "eval" or "value" (define cek-phase (fn (s) (get s "phase"))) -;; Extract the result value from a terminal CEK state (define cek-value (fn (s) (get s "value"))) -;; Frame for if: holds then/else branches, awaiting test result (define make-if-frame (fn (then-expr else-expr env) {:else else-expr :env env :type "if" :then then-expr})) -;; Frame for when: holds body, awaiting test result (define make-when-frame (fn (body-exprs env) {:body body-exprs :env env :type "when"})) -;; Frame for begin/do: holds remaining expressions (define make-begin-frame (fn (remaining env) {:env env :type "begin" :remaining remaining})) -;; Frame for let: holds remaining bindings and body (define make-let-frame (fn (name remaining body local) {:body body :env local :type "let" :remaining remaining :name name})) -;; Frame for define: holds name, awaiting value (define make-define-frame (fn (name env has-effects effect-list) {:env env :effect-list effect-list :has-effects has-effects :type "define" :name name})) -;; Frame for set!: holds name, awaiting new value (define make-set-frame (fn (name env) {:env env :type "set" :name name})) -;; Frame for function call: accumulates evaluated arguments (define make-arg-frame (fn (f evaled remaining env raw-args head-name) {:env env :head-name (or head-name nil) :evaled evaled :type "arg" :f f :remaining remaining :raw-args raw-args})) -;; Frame for call dispatch: holds function and args (define make-call-frame (fn (f args env) {:args args :env env :type "call" :f f})) -;; Frame for cond: holds remaining clauses (define make-cond-frame (fn (remaining env scheme?) {:scheme scheme? :env env :type "cond" :remaining remaining})) -;; Frame for case: holds match value and remaining clauses +(define make-cond-arrow-frame (fn (test-value env) {:env env :match-val test-value :type "cond-arrow"})) + (define make-case-frame (fn (match-val remaining env) {:match-val match-val :env env :type "case" :remaining remaining})) -;; Frame for -> threading: holds remaining forms (define make-thread-frame (fn (remaining env) {:env env :type "thread" :remaining remaining})) -;; Insert threaded value as first arg in a form (define thread-insert-arg (fn @@ -73,72 +55,56 @@ fenv) (eval-expr (list form (list (quote quote) value)) fenv)))) -;; Frame for map: accumulates results over remaining items (define make-map-frame (fn (f remaining results env) {:indexed false :env env :results results :type "map" :f f :remaining remaining})) -;; Frame for map-indexed: like map but tracks index (define make-map-indexed-frame (fn (f remaining results env) {:indexed true :env env :results results :type "map" :f f :remaining remaining})) -;; Frame for filter: accumulates items passing predicate +(define make-multi-map-frame (fn (f remaining-lists results env) {:env env :results results :type "multi-map" :f f :remaining remaining-lists})) + (define make-filter-frame (fn (f remaining results current-item env) {:current-item current-item :env env :results results :type "filter" :f f :remaining remaining})) -;; Frame for reduce: carries accumulator over remaining items (define make-reduce-frame (fn (f remaining env) {:env env :type "reduce" :f f :remaining remaining})) -;; Frame for for-each: side-effects over remaining items (define make-for-each-frame (fn (f remaining env) {:env env :type "for-each" :f f :remaining remaining})) -;; Frame for some: short-circuits on first truthy result (define make-some-frame (fn (f remaining env) {:env env :type "some" :f f :remaining remaining})) -;; Frame for every?: short-circuits on first falsy result (define make-every-frame (fn (f remaining env) {:env env :type "every" :f f :remaining remaining})) -;; Frame for scope: holds scope name, pops on completion (define make-scope-frame (fn (name remaining env) {:env env :type "scope" :remaining remaining :name name})) -;; Frame for provide: scope with a downward value (define make-provide-frame (fn (name value remaining env) {:env env :value value :type "provide" :remaining remaining :name name})) -;; Frame for scope accumulator: tracks emitted values (define make-scope-acc-frame (fn (name value remaining env) {:env env :value (or value nil) :type "scope-acc" :remaining remaining :emitted (list) :name name})) -;; Frame for reset: delimits continuation capture boundary (define make-reset-frame (fn (env) {:env env :type "reset"})) -;; Frame for dict literal: accumulates evaluated key-value pairs (define make-dict-frame (fn (remaining results env) {:env env :results results :type "dict" :remaining remaining})) -;; Frame for and: short-circuits on first falsy value (define make-and-frame (fn (remaining env) {:env env :type "and" :remaining remaining})) -;; Frame for or: short-circuits on first truthy value (define make-or-frame (fn (remaining env) {:env env :type "or" :remaining remaining})) -;; Frame for dynamic-wind: holds before/after thunks (define make-dynamic-wind-frame (fn (phase body-thunk after-thunk env) {:env env :phase phase :after-thunk after-thunk :type "dynamic-wind" :body-thunk body-thunk})) -;; Frame for reactive reset: delimits signal dependency tracking (define make-reactive-reset-frame (fn (env update-fn first-render?) {:first-render first-render? :update-fn update-fn :env env :type "reactive-reset"})) -;; Frame for deref: resolves signal value with dependency tracking +(define make-callcc-frame (fn (env) {:env env :type "callcc"})) + (define make-deref-frame (fn (env) {:env env :type "deref"})) -;; Frame for higher-order setup: staged arg evaluation for map/filter/etc. (define make-ho-setup-frame (fn (ho-type remaining-args evaled-args env) {:ho-type ho-type :env env :evaled evaled-args :type "ho-setup" :remaining remaining-args})) -;; Frame for component trace: records component render tree (define make-comp-trace-frame (fn (name file) {:env file :type "comp-trace" :name name})) -;; Walk continuation stack collecting component trace entries (define kont-collect-comp-trace (fn @@ -153,16 +119,14 @@ (cons {:file (get frame "file") :name (get frame "name")} (kont-collect-comp-trace (rest kont))) (kont-collect-comp-trace (rest kont))))))) -;; Frame for handler-bind: condition handler scope (define make-handler-frame (fn (handlers remaining env) {:env env :type "handler" :f handlers :remaining remaining})) -;; Frame for restart-case: named restart scope (define make-restart-frame (fn (restarts remaining env) {:env env :type "restart" :f restarts :remaining remaining})) -;; Frame for signal return: restores saved continuation after handler (define make-signal-return-frame (fn (env saved-kont) {:env env :type "signal-return" :f saved-kont})) -;; Search handler list for one matching a condition type +(define make-raise-eval-frame (fn (env continuable?) {:scheme continuable? :env env :type "raise-eval"})) + (define find-matching-handler (fn @@ -179,7 +143,6 @@ handler-fn (find-matching-handler (rest handlers) condition))))))) -;; Walk continuation stack looking for a matching handler frame (define kont-find-handler (fn @@ -199,7 +162,6 @@ match)) (kont-find-handler (rest kont) condition)))))) -;; Search restart list for one matching a name (define find-named-restart (fn @@ -214,7 +176,6 @@ entry (find-named-restart (rest restarts) name)))))) -;; Walk continuation stack looking for a named restart frame (define kont-find-restart (fn @@ -234,22 +195,16 @@ (list match frame (rest kont)))) (kont-find-restart (rest kont) name)))))) -;; Get the type tag of a continuation frame (define frame-type (fn (f) (get f "type"))) -;; Push a frame onto the continuation stack (define kont-push (fn (frame kont) (cons frame kont))) -;; Peek at the top frame of the continuation stack (define kont-top (fn (kont) (first kont))) -;; Pop the top frame, returning the rest of the stack (define kont-pop (fn (kont) (rest kont))) -;; True if the continuation stack has no frames (define kont-empty? (fn (kont) (empty? kont))) -;; Capture continuation frames up to the nearest reset delimiter (define kont-capture-to-reset (fn @@ -271,7 +226,6 @@ (scan (rest k) (append captured (list frame)))))))) (scan kont (list)))) -;; Walk stack looking for a provide frame with matching name (define kont-find-provide (fn @@ -288,7 +242,6 @@ frame (kont-find-provide (rest kont) name)))))) -;; Walk stack looking for a scope accumulator with matching name (define kont-find-scope-acc (fn @@ -305,7 +258,6 @@ frame (kont-find-scope-acc (rest kont) name)))))) -;; True if stack contains a reactive-reset frame (define has-reactive-reset-frame? (fn @@ -318,7 +270,6 @@ true (has-reactive-reset-frame? (rest kont)))))) -;; Capture frames up to the nearest reactive-reset delimiter (define kont-capture-to-reactive-reset (fn @@ -338,23 +289,18 @@ (scan (rest k) (append captured (list frame)))))))) (scan kont (list)))) -;; Registry of user-defined special forms (define *custom-special-forms* (dict)) -;; Register a function as a custom special form (define register-special-form! (fn ((name :as string) handler) (dict-set! *custom-special-forms* name handler))) -;; Function to check if a symbol is a renderable HTML tag (define *render-check* nil) -;; Function to render an HTML element (define *render-fn* nil) -;; Trampoline: repeatedly evaluate thunks until a non-thunk value (define trampoline (fn @@ -367,19 +313,14 @@ (trampoline (eval-expr (thunk-expr result) (thunk-env result))) result))))) -;; Flag: enable strict type checking mode (define *strict* false) -;; Enable or disable strict type checking (define set-strict! (fn (val) (set! *strict* val))) -;; Type specs for primitive function parameters (define *prim-param-types* nil) -;; Set the parameter type spec table for strict mode (define set-prim-param-types! (fn (types) (set! *prim-param-types* types))) -;; Check if a value matches a declared type (for strict mode) (define value-matches-type? (fn @@ -406,7 +347,6 @@ (slice expected-type 0 (- (string-length expected-type) 1)))) true))))) -;; Validate function arguments against declared types (define strict-check-args (fn @@ -476,10 +416,8 @@ (fn (i v) (list i v)) (slice args (len (or positional (list))))))))))))) -;; Evaluate an expression in an environment (CEK entry point) (define eval-expr (fn (expr (env :as dict)) nil)) -;; Call a lambda with evaluated args, binding params in closure env (define call-lambda (fn @@ -505,7 +443,6 @@ (slice params (len args))) (make-thunk (lambda-body f) local)))))) -;; Call a component with keyword args, binding params in closure env (define call-component (fn @@ -523,7 +460,6 @@ (env-bind! local "children" children)) (make-thunk (component-body comp) local)))) -;; Parse &key and &rest args from a component call (define parse-keyword-args (fn @@ -555,14 +491,23 @@ raw-args) (list kwargs children)))) -;; Detect if a cond uses scheme-style ((test body) ...) syntax (define cond-scheme? (fn ((clauses :as list)) - (every? (fn (c) (and (= (type-of c) "list") (= (len c) 2))) clauses))) + (every? + (fn + (c) + (and + (= (type-of c) "list") + (or + (= (len c) 2) + (and + (= (len c) 3) + (= (type-of (nth c 1)) "symbol") + (= (symbol-name (nth c 1)) "=>"))))) + clauses))) -;; True if a cond clause is the :else / else fallback (define is-else-clause? (fn @@ -573,7 +518,6 @@ (= (type-of test) "symbol") (or (= (symbol-name test) "else") (= (symbol-name test) ":else")))))) -;; Handle named let: (let name ((var val) ...) body) (define sf-named-let (fn @@ -621,7 +565,6 @@ ((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits))) (cek-call loop-fn init-vals)))))) -;; Construct a lambda value from params and body (define sf-lambda (fn @@ -651,7 +594,6 @@ params-expr))) (make-lambda param-names body env)))) -;; Handle defcomp: register a named component (define sf-defcomp (fn @@ -689,7 +631,6 @@ (env-bind! env (symbol-name name-sym) comp) comp)))) -;; Parse a single &key parameter with optional default (define defcomp-kwarg (fn @@ -712,7 +653,6 @@ (range 2 end 1)) result))) -;; Parse component parameter list (positional, &key, &rest) (define parse-comp-params (fn @@ -759,7 +699,6 @@ params-expr) (list params has-children param-types)))) -;; Handle defisland: register a reactive island component (define sf-defisland (fn @@ -785,7 +724,6 @@ (env-bind! env (symbol-name name-sym) island) island)))) -;; Handle defmacro: register a macro transformer (define sf-defmacro (fn @@ -802,7 +740,6 @@ (env-bind! env (symbol-name name-sym) mac) mac)))) -;; Parse macro parameter list (define parse-macro-params (fn @@ -831,7 +768,6 @@ params-expr) (list params rest-param)))) -;; Expand a quasiquote template, splicing unquoted values (define qq-expand (fn @@ -871,7 +807,6 @@ (list) template))))))) -;; Handle letrec: mutually recursive bindings (define sf-letrec (fn @@ -927,7 +862,6 @@ (slice body 0 (dec (len body)))) (make-thunk (last body) local)))) -;; CEK step for letrec continuation frame (define step-sf-letrec (fn @@ -936,7 +870,6 @@ ((thk (sf-letrec args env))) (make-cek-state (thunk-expr thk) (thunk-env thk) kont)))) -;; Handle dynamic-wind: before/body/after with guaranteed cleanup (define sf-dynamic-wind (fn @@ -947,7 +880,6 @@ (after (trampoline (eval-expr (nth args 2) env)))) (dynamic-wind-call before body after env)))) -;; Handle scope special form: push/pop named scope (define sf-scope (fn @@ -975,7 +907,6 @@ (scope-pop! name) result)))) -;; Handle provide: scope with a downward-propagating value (define sf-provide (fn @@ -992,7 +923,6 @@ (scope-pop! name) result))) -;; Expand a macro call: bind args, evaluate transformer body (define expand-macro (fn @@ -1018,14 +948,12 @@ (slice raw-args (len (macro-params mac))))) (trampoline (eval-expr (macro-body mac) local))))) -;; Run the CEK machine to completion, returning final value (define cek-run (fn (state) (if (cek-terminal? state) (cek-value state) (cek-run (cek-step state))))) -;; Single CEK machine step: eval or continue (define cek-step (fn @@ -1035,7 +963,6 @@ (step-eval state) (step-continue state)))) -;; Eval phase: dispatch on expression type (literal, symbol, list, dict) (define step-eval (fn @@ -1092,7 +1019,15 @@ (step-eval-list expr env kont)) :else (make-cek-value expr env kont))))) -;; Eval a list expression: check for special forms, macros, then call +(define + step-sf-raise + (fn + (args env kont) + (make-cek-state + (first args) + env + (kont-push (make-raise-eval-frame env false) kont)))) + (define step-eval-list (fn @@ -1133,7 +1068,54 @@ ("defisland" (make-cek-value (sf-defisland args env) env kont)) ("defmacro" (make-cek-value (sf-defmacro args env) env kont)) ("begin" (step-sf-begin args env kont)) - ("do" (step-sf-begin args env kont)) + ("do" + (if + (and + (not (empty? args)) + (list? (first args)) + (not (empty? (first args))) + (list? (first (first args)))) + (let + ((bindings (first args)) + (test-clause (nth args 1)) + (body (rest (rest args))) + (vars (map (fn (b) (first b)) bindings)) + (inits (map (fn (b) (nth b 1)) bindings)) + (steps + (map + (fn (b) (if (> (len b) 2) (nth b 2) (first b))) + bindings)) + (test (first test-clause)) + (result (rest test-clause))) + (step-eval-list + (cons + (quote let) + (cons + (quote __do-loop) + (cons + (map + (fn (b) (list (first b) (nth b 1))) + bindings) + (list + (cons + (quote if) + (cons + test + (cons + (if + (empty? result) + nil + (cons (quote begin) result)) + (list + (cons + (quote begin) + (append + body + (list + (cons (quote __do-loop) steps)))))))))))) + env + kont)) + (step-sf-begin args env kont))) ("quote" (make-cek-value (if (empty? args) nil (first args)) @@ -1166,6 +1148,15 @@ ("some" (step-ho-some args env kont)) ("every?" (step-ho-every args env kont)) ("for-each" (step-ho-for-each args env kont)) + ("raise" (step-sf-raise args env kont)) + ("raise-continuable" + (make-cek-state + (first args) + env + (kont-push (make-raise-eval-frame env true) kont))) + ("call/cc" (step-sf-callcc args env kont)) + ("call-with-current-continuation" + (step-sf-callcc args env kont)) (_ (cond (has-key? *custom-special-forms* name) @@ -1182,7 +1173,15 @@ :else (step-eval-call head args env kont))))) (step-eval-call head args env kont)))))) -;; Find matching clause in a match expression +(define + step-sf-callcc + (fn + (args env kont) + (make-cek-state + (first args) + env + (kont-push (make-callcc-frame env) kont)))) + (define match-find-clause (fn @@ -1200,7 +1199,6 @@ (list local body) (match-find-clause val (rest clauses) env)))))) -;; Match a value against a pattern, returning bindings or nil (define match-pattern (fn @@ -1233,7 +1231,6 @@ pairs))) :else (= pattern value)))) -;; CEK step for match special form (define step-sf-match (fn @@ -1248,7 +1245,6 @@ (error (str "match: no clause matched " (inspect val))) (make-cek-state (nth result 1) (first result) kont)))))) -;; CEK step for handler-bind (condition system) (define step-sf-handler-bind (fn @@ -1272,7 +1268,6 @@ env (kont-push (make-handler-frame handlers (rest body) env) kont)))))) -;; CEK step for restart-case (condition system) (define step-sf-restart-case (fn @@ -1297,7 +1292,6 @@ env (kont-push (make-restart-frame restarts (list) env) kont))))) -;; CEK step for signal (raise a condition) (define step-sf-signal (fn @@ -1315,7 +1309,6 @@ (list condition) (kont-push (make-signal-return-frame env kont) kont)))))) -;; CEK step for invoke-restart (jump to named restart) (define step-sf-invoke-restart (fn @@ -1344,7 +1337,6 @@ (env-bind! restart-env (first params) restart-arg)) (make-cek-state body restart-env rest-kont))))))) -;; CEK step for if: push if-frame, evaluate test (define step-sf-if (fn @@ -1359,7 +1351,6 @@ env) kont)))) -;; CEK step for when: push when-frame, evaluate test (define step-sf-when (fn @@ -1369,7 +1360,6 @@ env (kont-push (make-when-frame (rest args) env) kont)))) -;; CEK step for begin/do: evaluate forms sequentially (define step-sf-begin (fn @@ -1385,7 +1375,6 @@ env (kont-push (make-begin-frame (rest args) env) kont)))))) -;; CEK step for let: evaluate first binding value (define step-sf-let (fn @@ -1430,7 +1419,6 @@ (make-let-frame vname rest-bindings body local) kont))))))))) -;; CEK step for define: evaluate value, bind in env (define step-sf-define (fn @@ -1469,7 +1457,6 @@ effect-list) kont))))) -;; CEK step for set!: evaluate value, mutate existing binding (define step-sf-set! (fn @@ -1479,7 +1466,6 @@ env (kont-push (make-set-frame (symbol-name (first args)) env) kont)))) -;; CEK step for and: short-circuit on falsy (define step-sf-and (fn @@ -1492,7 +1478,6 @@ env (kont-push (make-and-frame (rest args) env) kont))))) -;; CEK step for or: short-circuit on truthy (define step-sf-or (fn @@ -1505,7 +1490,6 @@ env (kont-push (make-or-frame (rest args) env) kont))))) -;; CEK step for cond: evaluate first test (define step-sf-cond (fn @@ -1539,7 +1523,6 @@ env (kont-push (make-cond-frame args env false) kont))))))))) -;; CEK step for case: evaluate match value (define step-sf-case (fn @@ -1549,7 +1532,6 @@ env (kont-push (make-case-frame nil (rest args) env) kont)))) -;; CEK step for ->: thread value through forms (define step-sf-thread-first (fn @@ -1559,12 +1541,10 @@ env (kont-push (make-thread-frame (rest args) env) kont)))) -;; CEK step for lambda/fn: capture closure (define step-sf-lambda (fn (args env kont) (make-cek-value (sf-lambda args env) env kont))) -;; CEK step for scope: push scope, evaluate body (define step-sf-scope (fn @@ -1591,7 +1571,6 @@ env (kont-push (make-scope-acc-frame name val (rest body) env) kont)))))) -;; CEK step for provide: push scoped value, evaluate body (define step-sf-provide (fn @@ -1608,7 +1587,6 @@ env (kont-push (make-provide-frame name val (rest body) env) kont)))))) -;; CEK step for context: read value from nearest enclosing scope (define step-sf-context (fn @@ -1626,7 +1604,6 @@ env kont)))) -;; CEK step for emit!: append value to scope accumulator (define step-sf-emit (fn @@ -1643,7 +1620,6 @@ (append (get frame "emitted") (list val)))) (make-cek-value nil env kont)))) -;; CEK step for emitted: read accumulated values from scope (define step-sf-emitted (fn @@ -1656,7 +1632,6 @@ env kont)))) -;; CEK step for reset: push delimiter frame, evaluate body (define step-sf-reset (fn @@ -1666,7 +1641,6 @@ env (kont-push (make-reset-frame env) kont)))) -;; CEK step for shift: capture continuation to reset, call handler (define step-sf-shift (fn @@ -1684,7 +1658,6 @@ (env-bind! shift-env k-name k) (make-cek-state body shift-env rest-kont)))))) -;; CEK step for deref: resolve signal with dependency tracking (define step-sf-deref (fn @@ -1694,7 +1667,6 @@ env (kont-push (make-deref-frame env) kont)))) -;; Dispatch a function call: native fn, lambda, component, or macro (define cek-call (fn @@ -1708,7 +1680,6 @@ (cek-run (continue-with-call f a (make-env) a (list))) :else nil)))) -;; Deref inside reactive context: capture deps via shift (define reactive-shift-deref (fn @@ -1733,7 +1704,6 @@ ((initial-kont (concat captured-frames (list reset-frame) remaining-kont))) (make-cek-value (signal-value sig) env initial-kont))))))) -;; Evaluate function position, set up arg evaluation frames (define step-eval-call (fn @@ -1745,7 +1715,6 @@ env (kont-push (make-arg-frame nil (list) args env args hname) kont))))) -;; True if name is a higher-order form (map, filter, reduce, etc.) (define ho-form-name? (fn @@ -1759,10 +1728,8 @@ (= name "every?") (= name "for-each")))) -;; True if a value is a function (lambda or native callable) (define ho-fn? (fn (v) (or (callable? v) (lambda? v)))) -;; Auto-detect data-first vs fn-first arg order for HO forms (define ho-swap-args (fn @@ -1779,7 +1746,6 @@ ((a (first evaled)) (b (nth evaled 1))) (if (and (not (ho-fn? a)) (ho-fn? b)) (list b a) evaled))))) -;; Dispatch a higher-order form after args are evaluated (define ho-setup-dispatch (fn @@ -1791,17 +1757,37 @@ (match ho-type ("map" - (let - ((coll (nth ordered 1))) - (if - (empty? coll) - (make-cek-value (list) env kont) - (continue-with-call - f - (list (first coll)) - env - (list) - (kont-push (make-map-frame f (rest coll) (list) env) kont))))) + (if + (> (len ordered) 2) + (let + ((colls (rest ordered))) + (if + (some (fn (c) (empty? c)) colls) + (make-cek-value (list) env kont) + (let + ((heads (map (fn (c) (first c)) colls)) + (tails (map (fn (c) (rest c)) colls))) + (continue-with-call + f + heads + env + (list) + (kont-push + (make-multi-map-frame f tails (list) env) + kont))))) + (let + ((coll (nth ordered 1))) + (if + (empty? coll) + (make-cek-value (list) env kont) + (continue-with-call + f + (list (first coll)) + env + (list) + (kont-push + (make-map-frame f (rest coll) (list) env) + kont)))))) ("map-indexed" (let ((coll (nth ordered 1))) @@ -1885,7 +1871,6 @@ (kont-push (make-for-each-frame f (rest coll) env) kont))))) (_ (error (str "Unknown HO type: " ho-type)))))))) -;; CEK step for map: apply fn to next item, accumulate (define step-ho-map (fn @@ -1895,7 +1880,6 @@ env (kont-push (make-ho-setup-frame "map" (rest args) (list) env) kont)))) -;; CEK step for map-indexed: like map with index arg (define step-ho-map-indexed (fn @@ -1907,7 +1891,6 @@ (make-ho-setup-frame "map-indexed" (rest args) (list) env) kont)))) -;; CEK step for filter: test next item, keep if truthy (define step-ho-filter (fn @@ -1917,7 +1900,6 @@ env (kont-push (make-ho-setup-frame "filter" (rest args) (list) env) kont)))) -;; CEK step for reduce: apply fn to accumulator and next item (define step-ho-reduce (fn @@ -1927,7 +1909,6 @@ env (kont-push (make-ho-setup-frame "reduce" (rest args) (list) env) kont)))) -;; CEK step for some: return first truthy result (define step-ho-some (fn @@ -1937,7 +1918,6 @@ env (kont-push (make-ho-setup-frame "some" (rest args) (list) env) kont)))) -;; CEK step for every?: return false on first falsy (define step-ho-every (fn @@ -1947,7 +1927,6 @@ env (kont-push (make-ho-setup-frame "every" (rest args) (list) env) kont)))) -;; CEK step for for-each: apply fn for side effects (define step-ho-for-each (fn @@ -1959,7 +1938,6 @@ (make-ho-setup-frame "for-each" (rest args) (list) env) kont)))) -;; Continue phase: pop frame, dispatch on frame type (define step-continue (fn @@ -2117,7 +2095,20 @@ scheme? (if value - (make-cek-state (nth (first remaining) 1) fenv rest-k) + (let + ((clause (first remaining))) + (if + (and + (> (len clause) 2) + (= (type-of (nth clause 1)) "symbol") + (= (symbol-name (nth clause 1)) "=>")) + (make-cek-state + (nth clause 2) + fenv + (kont-push + (make-cond-arrow-frame value fenv) + rest-k)) + (make-cek-state (nth clause 1) fenv rest-k))) (let ((next-clauses (rest remaining))) (if @@ -2532,14 +2523,81 @@ ((saved-kont (get frame "saved-kont"))) (make-cek-value value (get frame "env") saved-kont))) ("comp-trace" (make-cek-value value env rest-k)) + ("cond-arrow" + (let + ((test-value (get frame "match-val")) + (fenv (get frame "env"))) + (continue-with-call + value + (list test-value) + fenv + (list test-value) + rest-k))) + ("raise-eval" + (let + ((condition value) + (fenv (get frame "env")) + (continuable? (get frame "scheme")) + (handler-fn (kont-find-handler rest-k condition))) + (if + (nil? handler-fn) + (host-error + (str "Unhandled exception: " (inspect condition))) + (continue-with-call + handler-fn + (list condition) + fenv + (list condition) + (if + continuable? + (kont-push + (make-signal-return-frame fenv rest-k) + rest-k) + (kont-push (make-raise-guard-frame fenv rest-k) rest-k)))))) + ("raise-guard" + (host-error + "exception handler returned from non-continuable raise")) + ("multi-map" + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (new-results (append (get frame "results") (list value))) + (fenv (get frame "env"))) + (if + (some (fn (c) (empty? c)) remaining) + (make-cek-value new-results fenv rest-k) + (let + ((heads (map (fn (c) (first c)) remaining)) + (tails (map (fn (c) (rest c)) remaining))) + (continue-with-call + f + heads + fenv + (list) + (kont-push + (make-multi-map-frame f tails new-results fenv) + rest-k)))))) + ("callcc" + (let + ((k (make-callcc-continuation rest-k))) + (continue-with-call + value + (list k) + (get frame "env") + (list k) + rest-k))) (_ (error (str "Unknown frame type: " ft))))))))) -;; Continue with a function call after args are evaluated (define continue-with-call (fn (f args env raw-args kont) (cond + (callcc-continuation? f) + (let + ((arg (if (empty? args) nil (first args))) + (captured (callcc-continuation-data f))) + (make-cek-value arg env captured)) (continuation? f) (let ((arg (if (empty? args) nil (first args))) @@ -2596,7 +2654,6 @@ kont))) :else (error (str "Not callable: " (inspect f)))))) -;; Case dispatch: iterate clauses matching against value (define sf-case-step-loop (fn @@ -2616,24 +2673,20 @@ (make-cek-state body env kont) (sf-case-step-loop match-val (slice clauses 2) env kont)))))))) -;; Full CEK evaluation: create initial state, run to completion (define eval-expr-cek (fn (expr env) (cek-run (make-cek-state expr env (list))))) -;; Trampoline wrapper for CEK: handles thunks from eval-expr-cek (define trampoline-cek (fn (val) (if (thunk? val) (eval-expr-cek (thunk-expr val) (thunk-env val)) val))) -;; Evaluate an expression in an environment (CEK entry point) (define eval-expr (fn (expr (env :as dict)) (cek-run (make-cek-state expr env (list))))) -;; Trampoline: repeatedly evaluate thunks until a non-thunk value (define trampoline (fn