From e1ef883339660da77e2411df79c62bda18133084 Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 29 Mar 2026 01:28:53 +0000 Subject: [PATCH] SX renderer: adapter-html.sx as sole renderer, conditions, pattern matching Evaluator: conditions/restarts, pattern matching, render-trace support. adapter-html.sx: full SX-defined HTML renderer replacing native OCaml. spec/render.sx: updated render mode helpers. sx_browser.ml: use SX render-to-html instead of native. sx_ref.ml: evaluator updates for conditions + match. Bootstrap + transpiler updates for new forms. Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/bin/integration_tests.ml | 2 +- hosts/ocaml/bin/mcp_tree.ml | 189 +- hosts/ocaml/bin/run_tests.ml | 61 +- hosts/ocaml/bin/sx_http.ml | 2 +- hosts/ocaml/bootstrap.py | 74 +- hosts/ocaml/browser/sx_browser.ml | 4 +- hosts/ocaml/lib/sx_primitives.ml | 4 + hosts/ocaml/lib/sx_ref.ml | 196 +- hosts/ocaml/lib/sx_runtime.ml | 2 +- hosts/ocaml/lib/sx_types.ml | 18 +- hosts/ocaml/transpiler.sx | 2 +- shared/static/scripts/sx-browser.js | 10 +- spec/evaluator.sx | 4082 ++++++++++++++------------ spec/render.sx | 579 ++-- web/adapter-html.sx | 555 +++- 15 files changed, 3460 insertions(+), 2320 deletions(-) diff --git a/hosts/ocaml/bin/integration_tests.ml b/hosts/ocaml/bin/integration_tests.ml index 463f248c..54ec5b19 100644 --- a/hosts/ocaml/bin/integration_tests.ml +++ b/hosts/ocaml/bin/integration_tests.ml @@ -407,7 +407,7 @@ let () = let render_html src = let exprs = Sx_parser.parse_all src in let expr = match exprs with [e] -> e | _ -> Nil in - Sx_render.render_to_html expr env + Sx_render.sx_render_to_html env expr env in (* Helper: call SX render-to-html via the adapter *) diff --git a/hosts/ocaml/bin/mcp_tree.ml b/hosts/ocaml/bin/mcp_tree.ml index 501fe143..69cb2c43 100644 --- a/hosts/ocaml/bin/mcp_tree.ml +++ b/hosts/ocaml/bin/mcp_tree.ml @@ -259,7 +259,14 @@ let setup_env () = (* Load eval-rules *) (try load_sx_file e (Filename.concat spec_dir "eval-rules.sx") with exn -> Printf.eprintf "[mcp] Warning: eval-rules.sx load failed: %s\n%!" (Printexc.to_string exn)); - Printf.eprintf "[mcp] SX tree-tools + harness + eval-rules loaded\n%!"; + (* Load render pipeline — native OCaml renderer + HTML tag bindings *) + Sx_render.setup_render_env e; + List.iter (fun tag -> + ignore (Sx_types.env_bind e tag + (NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args)))) + ) Sx_render.html_tags; + ignore (Sx_types.env_bind e "island?" (NativeFn ("island?", fun args -> match args with [Island _] -> Bool true | _ -> Bool false))); + Printf.eprintf "[mcp] SX tree-tools + harness + eval-rules + render loaded\n%!"; env := e (* ------------------------------------------------------------------ *) @@ -277,7 +284,9 @@ let parse_file path = List exprs let parse_path_str s = - (* Parse SX path string: "(0 3 2)" or "0 3 2" → SX list of numbers *) + (* Parse SX path string: "(0 3 2)" or "(0,3,2)" or "0 3 2" → SX list of numbers. + Commas are unquote in SX, so strip them before parsing. *) + let s = String.map (fun c -> if c = ',' then ' ' else c) s in let exprs = Sx_parser.parse_all s in match exprs with | [List items] -> @@ -1375,10 +1384,65 @@ let rec handle_tool name args = ) Nil exprs in text_result (Sx_runtime.value_to_str result) + | "sx_guard" -> + let expr_str = args |> member "expr" |> to_string in + let file = try Some (args |> member "file" |> to_string) with _ -> None in + let e = !env in + (match file with + | Some f -> (try load_sx_file e f with _ -> ()) + | None -> ()); + let exprs = Sx_parser.parse_all expr_str in + let conditions = ref [] in + (* Evaluate with error recovery — catch Eval_error, log it, return placeholder *) + let result = ref Nil in + (try + result := List.fold_left (fun _acc expr -> + Sx_ref.eval_expr expr (Env e) + ) Nil exprs + with Eval_error msg -> + let enhanced = Sx_ref.enhance_error_with_trace msg in + conditions := enhanced :: !conditions; + result := String ("")); + let cond_lines = match !conditions with + | [] -> "" + | cs -> "\n\nConditions signaled:\n" ^ + String.concat "\n" (List.rev_map (fun c -> " - " ^ c) cs) in + text_result (Sx_runtime.value_to_str !result ^ cond_lines) + + | "sx_render_trace" -> + let expr_str = args |> member "expr" |> to_string in + let file = try Some (args |> member "file" |> to_string) with _ -> None in + let e = !env in + (match file with + | Some f -> (try load_sx_file e f with _ -> ()) + | None -> ()); + let exprs = Sx_parser.parse_all expr_str in + let expr = match exprs with [e] -> e | _ -> List (Symbol "do" :: exprs) in + let trace = Buffer.create 2048 in + let truncate s n = if String.length s > n then String.sub s 0 n ^ "..." else s in + let expr_str = truncate (Sx_runtime.value_to_str expr) 60 in + let kind = match expr with + | Nil -> "nil" | Bool _ -> "bool" | Number _ -> "number" + | String _ -> "string" | Symbol _ -> "symbol" | Keyword _ -> "keyword" + | RawHTML _ -> "raw-html" + | List (Symbol s :: _) | ListRef { contents = Symbol s :: _ } -> + if List.mem s Sx_render.html_tags then "element:" ^ s + else if List.mem s ["if";"when";"cond";"case";"let";"let*";"do";"begin";"map";"filter";"define";"defcomp"] then "form:" ^ s + else "call:" ^ s + | List _ -> "list" | _ -> "other" in + Buffer.add_string trace (Printf.sprintf "→ %s %s\n" kind expr_str); + let result = (try + Sx_render.sx_render_to_html e expr e + with Sx_types.Eval_error msg -> "ERROR: " ^ Sx_ref.enhance_error_with_trace msg) in + let result_str = truncate result 60 in + Buffer.add_string trace (Printf.sprintf "← %s\n" result_str); + text_result (Printf.sprintf "Result: %s\n\nRender trace:\n%s" result (Buffer.contents trace)) + | "sx_trace" -> let expr_str = args |> member "expr" |> to_string in let max_steps = (try args |> member "max_steps" |> to_int with _ -> 200) in let file = try Some (args |> member "file" |> to_string) with _ -> None in + let components_only = (try args |> member "components_only" |> to_bool with _ -> false) in let e = !env in (match file with | Some f -> (try load_sx_file e f with _ -> ()) @@ -1389,6 +1453,29 @@ let rec handle_tool name args = let steps = Buffer.create 2048 in let step_count = ref 0 in let truncate s n = if String.length s > n then String.sub s 0 n ^ "..." else s in + (* Track comp-trace depth for component-only mode *) + let comp_depth = ref 0 in + let prev_comp_depth = ref 0 in + let get_frame_type kont = match kont with + | List (CekFrame f :: _) -> f.cf_type + | List (Dict d :: _) -> + (match Hashtbl.find_opt d "type" with Some (String s) -> s | _ -> "?") + | _ -> "done" in + let count_comp_trace kont = + let n = ref 0 in + let k = ref kont in + (try while true do + (match !k with + | List (CekFrame f :: rest) -> + if f.cf_type = "comp-trace" then incr n; + k := List rest + | List (Dict d :: rest) -> + (match Hashtbl.find_opt d "type" with + | Some (String "comp-trace") -> incr n | _ -> ()); + k := List rest + | _ -> raise Exit) + done with Exit -> ()); + !n in (try while !step_count < max_steps do let s = !state in @@ -1396,44 +1483,56 @@ let rec handle_tool name args = | CekState cs -> incr step_count; let n = !step_count in - if cs.cs_phase = "eval" then begin - let ctrl = cs.cs_control in - (match ctrl with - | Symbol sym_name -> - let resolved = (try - let v = Sx_ref.eval_expr ctrl cs.cs_env in - truncate (Sx_runtime.value_to_str v) 60 - with _ -> "???") in - Buffer.add_string steps - (Printf.sprintf "%3d LOOKUP %s → %s\n" n sym_name resolved) - | List (hd :: _) -> - let head_str = truncate (Sx_runtime.value_to_str hd) 30 in - let ctrl_str = truncate (Sx_runtime.value_to_str ctrl) 80 in - Buffer.add_string steps - (Printf.sprintf "%3d CALL %s\n" n ctrl_str); - ignore head_str - | _ -> - Buffer.add_string steps - (Printf.sprintf "%3d LITERAL %s\n" n - (truncate (Sx_runtime.value_to_str ctrl) 60))) + if components_only then begin + let depth = count_comp_trace cs.cs_kont in + (if depth > !prev_comp_depth then begin + let indent = String.make (depth * 2) ' ' in + let ft = get_frame_type cs.cs_kont in + let name = (match cs.cs_kont with + | List (CekFrame f :: _) when f.cf_type = "comp-trace" -> + (match f.cf_name with String s -> s | _ -> "?") + | _ -> "?") in + Buffer.add_string steps + (Printf.sprintf "%s→ ENTER ~%s\n" indent name); + ignore ft + end else if depth < !prev_comp_depth then begin + let indent = String.make ((depth + 1) * 2) ' ' in + let val_str = if cs.cs_phase = "continue" + then truncate (Sx_runtime.value_to_str cs.cs_value) 60 + else "..." in + Buffer.add_string steps + (Printf.sprintf "%s← EXIT → %s\n" indent val_str) + end); + prev_comp_depth := depth end else begin - (* continue phase *) - let val_str = truncate (Sx_runtime.value_to_str cs.cs_value) 60 in - let kont = cs.cs_kont in - let frame_type = match kont with - | List (Dict d :: _) -> - (match Hashtbl.find_opt d "type" with - | Some (String s) -> s | _ -> "?") - | List (CekState ks :: _) -> - (match ks.cs_control with - | Dict d -> - (match Hashtbl.find_opt d "type" with - | Some (String s) -> s | _ -> "?") - | _ -> "?") - | _ -> "done" in - Buffer.add_string steps - (Printf.sprintf "%3d RETURN %s → %s\n" n val_str frame_type) + if cs.cs_phase = "eval" then begin + let ctrl = cs.cs_control in + (match ctrl with + | Symbol sym_name -> + let resolved = (try + let v = Sx_ref.eval_expr ctrl cs.cs_env in + truncate (Sx_runtime.value_to_str v) 60 + with _ -> "???") in + Buffer.add_string steps + (Printf.sprintf "%3d LOOKUP %s → %s\n" n sym_name resolved) + | List (hd :: _) -> + let head_str = truncate (Sx_runtime.value_to_str hd) 30 in + let ctrl_str = truncate (Sx_runtime.value_to_str ctrl) 80 in + Buffer.add_string steps + (Printf.sprintf "%3d CALL %s\n" n ctrl_str); + ignore head_str + | _ -> + Buffer.add_string steps + (Printf.sprintf "%3d LITERAL %s\n" n + (truncate (Sx_runtime.value_to_str ctrl) 60))) + end else begin + let val_str = truncate (Sx_runtime.value_to_str cs.cs_value) 60 in + let ft = get_frame_type cs.cs_kont in + Buffer.add_string steps + (Printf.sprintf "%3d RETURN %s → %s\n" n val_str ft) + end end; + ignore comp_depth; (match Sx_ref.cek_terminal_p s with | Bool true -> raise Exit | _ -> ()); @@ -1443,7 +1542,8 @@ let rec handle_tool name args = with | Exit -> () | Eval_error msg -> - Buffer.add_string steps (Printf.sprintf "ERROR: %s\n" msg) + let enhanced = Sx_ref.enhance_error_with_trace msg in + Buffer.add_string steps (Printf.sprintf "ERROR: %s\n" enhanced) | exn -> Buffer.add_string steps (Printf.sprintf "ERROR: %s\n" (Printexc.to_string exn))); let final_val = (match !state with @@ -1714,10 +1814,17 @@ let tool_definitions = `List [ [file_prop; path_prop; ("wrapper", `Assoc [("type", `String "string"); ("description", `String "Wrapper with _ placeholder")])] ["file"; "path"; "wrapper"]; tool "sx_eval" "Evaluate an SX expression. Environment has parser + tree-tools + primitives." [("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to evaluate")])] ["expr"]; - tool "sx_trace" "Step-through SX evaluation showing each CEK machine step (symbol lookups, function calls, returns). Useful for debugging." + tool "sx_guard" "Evaluate with error recovery. Catches errors, shows component trace, and continues. Returns result + any conditions signaled." + [("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to evaluate with error recovery")]); + ("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")])] ["expr"]; + tool "sx_render_trace" "Render an SX expression to HTML with full dispatch tracing. Shows which render path each sub-expression takes." + [("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to render with tracing")]); + ("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")])] ["expr"]; + tool "sx_trace" "Step-through SX evaluation showing each CEK machine step (symbol lookups, function calls, returns). Set components_only=true for component entry/exit only." [("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to trace")]); ("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")]); - ("max_steps", `Assoc [("type", `String "integer"); ("description", `String "Max CEK steps to show (default: 200)")])] ["expr"]; + ("max_steps", `Assoc [("type", `String "integer"); ("description", `String "Max CEK steps to show (default: 200)")]); + ("components_only", `Assoc [("type", `String "boolean"); ("description", `String "Show only component entry/exit events (default: false)")])] ["expr"]; tool "sx_explain" "Explain SX evaluation rules. Pass a form name (if, let, map, ...) or category (literal, special-form, higher-order, ...)." [("name", `Assoc [("type", `String "string"); ("description", `String "Form name or category to explain")])] ["name"]; tool "sx_deps" "Dependency analysis for a component or file. Shows all referenced symbols and where they're defined." diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 1a9f9f4b..40392abe 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -292,10 +292,15 @@ let make_test_env () = bind "eval-expr" (fun args -> match args with | [expr; e] -> + (match e with + | Dict _ -> Printf.eprintf "[EVAL-EXPR] env is Dict! expr=%s\n%!" (Sx_runtime.value_to_str expr) + | Nil -> Printf.eprintf "[EVAL-EXPR] env is Nil! expr=%s\n%!" (Sx_runtime.value_to_str expr) + | _ -> ()); let ue = Sx_runtime.unwrap_env e in eval_expr expr (Env ue) | [expr] -> eval_expr expr (Env env) | _ -> raise (Eval_error "eval-expr: expected (expr env)")); + bind "set-render-active!" (fun _args -> Nil); (* Scope primitives — use a local scope stacks table. Must match the same pattern as sx_server.ml's _scope_stacks. *) let _scope_stacks : (string, Sx_types.value list) Hashtbl.t = Hashtbl.create 8 in @@ -354,20 +359,62 @@ let make_test_env () = bind "cond-scheme?" (fun args -> match args with | [(List clauses | ListRef { contents = clauses })] -> - (match clauses with - | (List _ | ListRef _) :: _ -> Bool true - | _ -> Bool false) + Bool (List.for_all (fun c -> + match c with + | List l | ListRef { contents = l } -> List.length l = 2 + | _ -> false + ) clauses) | _ -> Bool false); bind "expand-macro" (fun args -> match args with | [Macro m; (List a | ListRef { contents = a }); _] -> let local = Sx_types.env_extend m.m_closure in - List.iteri (fun i p -> - ignore (Sx_types.env_bind local p (if i < List.length a then List.nth a i else Nil)) - ) m.m_params; + let rec bind_params ps as' = + match ps, as' with + | [], rest -> + (match m.m_rest_param with + | Some rp -> ignore (Sx_types.env_bind local rp (List rest)) + | None -> ()) + | p :: ps_rest, a :: as_rest -> + ignore (Sx_types.env_bind local p a); + bind_params ps_rest as_rest + | remaining, [] -> + List.iter (fun p -> ignore (Sx_types.env_bind local p Nil)) remaining + in + bind_params m.m_params a; eval_expr m.m_body (Env local) | _ -> raise (Eval_error "expand-macro: expected (macro args env)")); + (* Declarative type/effect forms — no-ops at runtime *) + bind "deftype" (fun _args -> Nil); + bind "defeffect" (fun _args -> Nil); + + (* --- Primitives for canonical.sx / content tests --- *) + bind "contains-char?" (fun args -> + match args with + | [String s; String c] when String.length c = 1 -> + Bool (String.contains s c.[0]) + | _ -> Bool false); + bind "escape-string" (fun args -> + match args with + | [String s] -> + let buf = Buffer.create (String.length s + 4) in + String.iter (fun c -> match c with + | '"' -> Buffer.add_string buf "\\\"" + | '\\' -> Buffer.add_string buf "\\\\" + | '\n' -> Buffer.add_string buf "\\n" + | '\t' -> Buffer.add_string buf "\\t" + | c -> Buffer.add_char buf c) s; + String (Buffer.contents buf) + | _ -> raise (Eval_error "escape-string: expected string")); + bind "sha3-256" (fun args -> + match args with + | [String s] -> + (* Stub: use a simple hash for testing — not real SHA3 *) + let h = Hashtbl.hash s in + String (Printf.sprintf "%064x" (abs h)) + | _ -> raise (Eval_error "sha3-256: expected string")); + (* --- Missing primitives referenced by tests --- *) bind "upcase" (fun args -> @@ -467,6 +514,8 @@ let make_test_env () = bind "component-param-types" (fun _args -> Nil); bind "component-set-param-types!" (fun _args -> Nil); + bind "component-file" (fun args -> match args with [v] -> component_file v | _ -> Nil); + bind "component-set-file!" (fun args -> match args with [v; f] -> component_set_file v f | _ -> Nil); bind "component-params" (fun args -> match args with diff --git a/hosts/ocaml/bin/sx_http.ml b/hosts/ocaml/bin/sx_http.ml index 4cbf57fd..48e730c0 100644 --- a/hosts/ocaml/bin/sx_http.ml +++ b/hosts/ocaml/bin/sx_http.ml @@ -226,7 +226,7 @@ let sx_render_to_html expr env = let result = Sx_ref.cek_call fn (List [expr; Env env]) in match result with String s -> s | _ -> Sx_runtime.value_to_str result else - Sx_render.render_to_html expr env + Sx_render.sx_render_to_html env expr env (* ====================================================================== *) diff --git a/hosts/ocaml/bootstrap.py b/hosts/ocaml/bootstrap.py index 45feb812..aa4012ad 100644 --- a/hosts/ocaml/bootstrap.py +++ b/hosts/ocaml/bootstrap.py @@ -60,6 +60,9 @@ let _prim_param_types_ref = ref Nil run with hook = None (pure CEK, no compilation dependency). *) let jit_call_hook : (value -> value list -> value option) option ref = ref None +(* Component trace — captures kont from last CEK error for diagnostics *) +let _last_error_kont : value ref = ref Nil + """ @@ -75,13 +78,58 @@ 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 *) +(* 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 - while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do - s := cek_step !s + (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 + let k = ref kont in + while (match !k with List (_::_) -> true | _ -> false) do + (match !k with + | List (frame :: rest) -> + (match frame with + | CekFrame f when f.cf_type = "comp-trace" -> + let name = match f.cf_name with String s -> s | _ -> "?" in + let file = match f.cf_env with String s -> s | Nil -> "" | _ -> "" in + trace := (name, file) :: !trace + | Dict d when (match Hashtbl.find_opt d "type" with Some (String "comp-trace") -> true | _ -> false) -> + let name = match Hashtbl.find_opt d "name" with Some (String s) -> s | _ -> "?" in + let file = match Hashtbl.find_opt d "file" with Some (String s) -> s | _ -> "" in + trace := (name, file) :: !trace + | _ -> ()); + k := List rest + | _ -> k := List []) done; - cek_value !s + List.rev !trace + +(* Format a comp-trace into a human-readable string *) +let format_comp_trace trace = + match trace with + | [] -> "" + | entries -> + let lines = List.mapi (fun i (name, file) -> + let prefix = if i = 0 then " in " else " called from " in + if file = "" then prefix ^ "~" ^ name + else prefix ^ "~" ^ name ^ " (" ^ file ^ ")" + ) entries in + "\n" ^ String.concat "\n" lines + +(* Enhance an error message with component trace *) +let enhance_error_with_trace msg = + let trace = collect_comp_trace !_last_error_kont in + _last_error_kont := Nil; + msg ^ (format_comp_trace trace) @@ -248,6 +296,24 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str: import sys print("WARNING: Could not find lambda body pattern for JIT injection", file=sys.stderr) + # Instrument recursive cek_run to capture kont on error (for comp-trace). + # The iterative cek_run_iterative already does this, but cek_call uses + # the recursive cek_run. + cek_run_old = ( + 'and cek_run state =\n' + ' (if sx_truthy ((cek_terminal_p (state))) then (cek_value (state)) else (cek_run ((cek_step (state)))))' + ) + cek_run_new = ( + 'and cek_run state =\n' + ' (if sx_truthy ((cek_terminal_p (state))) then (cek_value (state)) else\n' + ' try cek_run ((cek_step (state)))\n' + ' with Eval_error msg ->\n' + ' (if !_last_error_kont = Nil then _last_error_kont := cek_kont state);\n' + ' raise (Eval_error msg))' + ) + if cek_run_old in output: + output = output.replace(cek_run_old, cek_run_new, 1) + return output diff --git a/hosts/ocaml/browser/sx_browser.ml b/hosts/ocaml/browser/sx_browser.ml index beae0410..ed1ad54d 100644 --- a/hosts/ocaml/browser/sx_browser.ml +++ b/hosts/ocaml/browser/sx_browser.ml @@ -375,7 +375,7 @@ let api_render_to_html expr_js = let prev = !_sx_render_mode in _sx_render_mode := true; (try - let html = Sx_render.render_to_html expr global_env in + let html = Sx_render.sx_render_to_html global_env expr global_env in _sx_render_mode := prev; Js.Unsafe.inject (Js.string html) with Eval_error msg -> @@ -641,7 +641,7 @@ let () = bind "<>" (fun args -> RawHTML (String.concat "" (List.map (fun a -> match a with String s | RawHTML s -> s | Nil -> "" - | List _ -> Sx_render.render_to_html a global_env + | List _ -> Sx_render.sx_render_to_html global_env a global_env | _ -> value_to_string a) args))); bind "raw!" (fun args -> RawHTML (String.concat "" (List.map (fun a -> diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 1dc86f91..f93ea57c 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -854,6 +854,10 @@ let () = | [Component c] -> c.c_body | [Island i] -> i.i_body | _ -> Nil); + register "component-file" (fun args -> + match args with [v] -> component_file v | _ -> Nil); + register "component-set-file!" (fun args -> + match args with [v; f] -> component_set_file v f | _ -> Nil); register "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false); register "for-each-indexed" (fun args -> diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index e3007750..782e80ad 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -23,6 +23,9 @@ let _prim_param_types_ref = ref Nil run with hook = None (pure CEK, no compilation dependency). *) let jit_call_hook : (value -> value list -> value option) option ref = ref None +(* Component trace — captures kont from last CEK error for diagnostics *) +let _last_error_kont : value ref = ref Nil + (* === Transpiled from evaluator (frames + eval + CEK) === *) @@ -175,6 +178,42 @@ and make_deref_frame env = and make_ho_setup_frame ho_type remaining_args evaled_args env = (CekFrame { cf_type = "ho-setup"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining_args; cf_f = Nil; cf_args = evaled_args; cf_results = Nil; cf_extra = ho_type; cf_extra2 = Nil }) +(* make-comp-trace-frame *) +and make_comp_trace_frame name file = + (CekFrame { cf_type = "comp-trace"; cf_env = file; cf_name = name; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) + +(* kont-collect-comp-trace *) +and kont_collect_comp_trace kont = + (if sx_truthy ((empty_p (kont))) then (List []) else (let frame = (first (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "comp-trace")])) then (cons ((let _d = Hashtbl.create 2 in Hashtbl.replace _d "file" (get (frame) ((String "file"))); Hashtbl.replace _d "name" (get (frame) ((String "name"))); Dict _d)) ((kont_collect_comp_trace ((rest (kont)))))) else (kont_collect_comp_trace ((rest (kont))))))) + +(* make-handler-frame *) +and make_handler_frame handlers remaining env = + (CekFrame { cf_type = "handler"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = handlers; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) + +(* make-restart-frame *) +and make_restart_frame restarts remaining env = + (CekFrame { cf_type = "restart"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = restarts; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) + +(* make-signal-return-frame *) +and make_signal_return_frame env saved_kont = + (CekFrame { cf_type = "signal-return"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = saved_kont; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) + +(* find-matching-handler *) +and find_matching_handler handlers condition = + (if sx_truthy ((empty_p (handlers))) then Nil else (let pair = (first (handlers)) in (let pred = (first (pair)) in let handler_fn = (nth (pair) ((Number 1.0))) in (if sx_truthy ((cek_call (pred) ((List [condition])))) then handler_fn else (find_matching_handler ((rest (handlers))) (condition)))))) + +(* kont-find-handler *) +and kont_find_handler kont condition = + (if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "handler")])) then (let match' = (find_matching_handler ((get (frame) ((String "f")))) (condition)) in (if sx_truthy ((is_nil (match'))) then (kont_find_handler ((rest (kont))) (condition)) else match')) else (kont_find_handler ((rest (kont))) (condition))))) + +(* find-named-restart *) +and find_named_restart restarts name = + (if sx_truthy ((empty_p (restarts))) then Nil else (let entry = (first (restarts)) in (if sx_truthy ((prim_call "=" [(first (entry)); name])) then entry else (find_named_restart ((rest (restarts))) (name))))) + +(* kont-find-restart *) +and kont_find_restart kont name = + (if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "restart")])) then (let match' = (find_named_restart ((get (frame) ((String "f")))) (name)) in (if sx_truthy ((is_nil (match'))) then (kont_find_restart ((rest (kont))) (name)) else (List [match'; frame; (rest (kont))]))) else (kont_find_restart ((rest (kont))) (name))))) + (* frame-type *) and frame_type f = (get (f) ((String "type"))) @@ -253,43 +292,9 @@ and value_matches_type_p val' expected_type = and strict_check_args name args = (if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else !_prim_param_types_ref)) then (let spec = (get (!_prim_param_types_ref) (name)) in (if sx_truthy (spec) then (let positional = (get (spec) ((String "positional"))) in let rest_type = (get (spec) ((String "rest-type"))) in (let () = ignore ((if sx_truthy (positional) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let param = (nth (pair) ((Number 1.0))) in let p_name = (first (param)) in let p_type = (nth (param) ((Number 1.0))) in (if sx_truthy ((prim_call "<" [idx; (len (args))])) then (let val' = (nth (args) (idx)) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (p_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); p_type; (String " for param "); p_name; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [i; p])) (sx_to_list positional)))); Nil) else Nil)) in (if sx_truthy ((let _and = rest_type in if not (sx_truthy _and) then _and else (prim_call ">" [(len (args)); (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let val' = (nth (pair) ((Number 1.0))) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (rest_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); rest_type; (String " for rest arg "); idx; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)))) (sx_to_list (List (List.mapi (fun i v -> let i = Number (float_of_int i) in (List [i; v])) (sx_to_list (prim_call "slice" [args; (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))))); Nil) else Nil))) else Nil)) else Nil) -(* bind_lambda_params — shared helper for call-lambda and CEK dispatch. - Handles &rest params: binds required params, collects rest into list. *) -and bind_lambda_params f args local = - let params = lambda_params f in - let param_list = match params with List l | ListRef { contents = l } -> l | _ -> [] in - let args_list = match args with List l | ListRef { contents = l } -> l | _ -> [] in - let rest_idx = ref (-1) in - List.iteri (fun i p -> match p with Symbol "&rest" | String "&rest" -> rest_idx := i | _ -> ()) param_list; - if !rest_idx >= 0 then begin - let required = List.filteri (fun i _ -> i < !rest_idx) param_list in - let rest_name = (match List.nth_opt param_list (!rest_idx + 1) with - | Some (Symbol s | String s) -> s | _ -> "rest") in - List.iteri (fun i p -> - let name = sx_to_string p in - let v = match List.nth_opt args_list i with Some v -> v | None -> Nil in - ignore (env_bind local name v)) required; - let rest_vals = if !rest_idx <= List.length args_list - then List (List.filteri (fun i _ -> i >= !rest_idx) args_list) else List [] in - ignore (env_bind local (String rest_name) rest_vals) - end else begin - 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])))); - 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]))); - ignore (List.iter (fun p -> - ignore (env_bind local (sx_to_string p) Nil)) - (sx_to_list (prim_call "slice" [params; len args]))) - end - -(* call-lambda — uses shared bind_lambda_params for &rest support *) +(* call-lambda *) and call_lambda f args caller_env = - let local = env_merge (lambda_closure f) caller_env in - bind_lambda_params f args local; - make_thunk (lambda_body f) local + (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (caller_env)) in (if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil)) in (make_thunk ((lambda_body (f))) (local)))))) (* call-component *) and call_component comp raw_args env = @@ -317,7 +322,7 @@ and sf_lambda args env = (* sf-defcomp *) and sf_defcomp args env = - (let name_sym = (first (args)) in let params_raw = (nth (args) ((Number 1.0))) in let body = (last (args)) in let comp_name = (strip_prefix ((symbol_name (name_sym))) ((String "~"))) in let parsed = (parse_comp_params (params_raw)) in let params = (first (parsed)) in let has_children = (nth (parsed) ((Number 1.0))) in let param_types = (nth (parsed) ((Number 2.0))) in let affinity = (defcomp_kwarg (args) ((String "affinity")) ((String "auto"))) in (let comp = (make_component (comp_name) (params) (has_children) (body) (env) (affinity)) in let effects = (defcomp_kwarg (args) ((String "effects")) (Nil)) in (let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy ((is_nil (param_types)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((empty_p ((prim_call "keys" [param_types]))))))))) then (component_set_param_types_b (comp) (param_types)) else Nil)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((is_nil (effects))))))) then (let effect_list = (if sx_truthy ((prim_call "=" [(type_of (effects)); (String "list")])) then (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else (String (sx_str [e])))) (sx_to_list effects))) else (List [(String (sx_str [effects]))])) in let effect_anns = (if sx_truthy ((env_has (env) ((String "*effect-annotations*")))) then (env_get (env) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns (symbol_name (name_sym)) effect_list)) in (env_bind env (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) comp)) in comp))))) + (let name_sym = (first (args)) in let params_raw = (nth (args) ((Number 1.0))) in let body = (last (args)) in let comp_name = (strip_prefix ((symbol_name (name_sym))) ((String "~"))) in let parsed = (parse_comp_params (params_raw)) in let params = (first (parsed)) in let has_children = (nth (parsed) ((Number 1.0))) in let param_types = (nth (parsed) ((Number 2.0))) in let affinity = (defcomp_kwarg (args) ((String "affinity")) ((String "auto"))) in (let comp = (make_component (comp_name) (params) (has_children) (body) (env) (affinity)) in let effects = (defcomp_kwarg (args) ((String "effects")) (Nil)) in (let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy ((is_nil (param_types)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((empty_p ((prim_call "keys" [param_types]))))))))) then (component_set_param_types_b (comp) (param_types)) else Nil)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((is_nil (effects))))))) then (let effect_list = (if sx_truthy ((prim_call "=" [(type_of (effects)); (String "list")])) then (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else (String (sx_str [e])))) (sx_to_list effects))) else (List [(String (sx_str [effects]))])) in let effect_anns = (if sx_truthy ((env_has (env) ((String "*effect-annotations*")))) then (env_get (env) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns (symbol_name (name_sym)) effect_list)) in (env_bind env (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (let () = ignore ((if sx_truthy ((env_has (env) ((String "*current-file*")))) then (component_set_file_b (comp) ((env_get (env) ((String "*current-file*"))))) else Nil)) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) comp)) in comp)))))) (* defcomp-kwarg *) and defcomp_kwarg args key default = @@ -327,9 +332,9 @@ and defcomp_kwarg args key default = and parse_comp_params params_expr = (let params = ref ((List [])) in let param_types = (Dict (Hashtbl.create 0)) in let has_children = ref ((Bool false)) in let in_key = ref ((Bool false)) in (let () = ignore ((List.iter (fun p -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (p)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (p)); (Number 3.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (p)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (p) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (p) ((Number 1.0))))); (String "as")])))))) then (let name = (symbol_name ((first (p)))) in let ptype = (nth (p) ((Number 2.0))) in (let type_val = (if sx_truthy ((prim_call "=" [(type_of (ptype)); (String "symbol")])) then (symbol_name (ptype)) else ptype) in (if sx_truthy ((Bool (not (sx_truthy (!has_children))))) then (let () = ignore ((params := sx_append_b !params name; Nil)) in (sx_dict_set_b param_types name type_val)) else Nil))) else (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (let name = (symbol_name (p)) in (if sx_truthy ((prim_call "=" [name; (String "&key")])) then (in_key := (Bool true); Nil) else (if sx_truthy ((prim_call "=" [name; (String "&rest")])) then (has_children := (Bool true); Nil) else (if sx_truthy ((prim_call "=" [name; (String "&children")])) then (has_children := (Bool true); Nil) else (if sx_truthy (!has_children) then Nil else (if sx_truthy (!in_key) then (params := sx_append_b !params name; Nil) else (params := sx_append_b !params name; Nil))))))) else Nil)))) (sx_to_list params_expr); Nil)) in (List [!params; !has_children; param_types]))) -(* sf-defisland — multi-expression bodies wrapped in (begin ...) *) +(* sf-defisland *) and sf_defisland args env = - (let name_sym = (first (args)) in let params_raw = (nth (args) ((Number 1.0))) in let body_exprs = (slice (args) ((Number 2.0))) in let body = (if sx_truthy ((prim_call "=" [(len (body_exprs)); (Number 1.0)])) then (first (body_exprs)) else (prim_call "cons" [(make_symbol ((String "begin"))); body_exprs])) in let comp_name = (strip_prefix ((symbol_name (name_sym))) ((String "~"))) in let parsed = (parse_comp_params (params_raw)) in let params = (first (parsed)) in let has_children = (nth (parsed) ((Number 1.0))) in (let island = (make_island (comp_name) (params) (has_children) (body) (env)) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) island)) in island))) + (let name_sym = (first (args)) in let params_raw = (nth (args) ((Number 1.0))) in let body_exprs = (prim_call "slice" [args; (Number 2.0)]) in let body = (if sx_truthy ((prim_call "=" [(len (body_exprs)); (Number 1.0)])) then (first (body_exprs)) else (cons ((make_symbol ((String "begin")))) (body_exprs))) in let comp_name = (strip_prefix ((symbol_name (name_sym))) ((String "~"))) in let parsed = (parse_comp_params (params_raw)) in let params = (first (parsed)) in let has_children = (nth (parsed) ((Number 1.0))) in (let island = (make_island (comp_name) (params) (has_children) (body) (env)) in (let () = ignore ((if sx_truthy ((env_has (env) ((String "*current-file*")))) then (component_set_file_b (island) ((env_get (env) ((String "*current-file*"))))) else Nil)) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) island)) in island)))) (* sf-defmacro *) and sf_defmacro args env = @@ -367,13 +372,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 stack overflow in js_of_ocaml/WASM *) +(* cek-run *) and cek_run state = - let s = ref state in - while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do - s := cek_step !s - done; - cek_value !s + (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 = @@ -385,14 +390,35 @@ and step_eval state = (* 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 ( - (* Desugar (define (name args...) body...) → (define name (fn (args...) body...)) *) - match args with - | List (List (Symbol fname :: fparams) :: body) | ListRef { contents = List (Symbol fname :: fparams) :: body } -> - let fn_form = List [Symbol "fn"; List fparams; (match body with [b] -> b | _ -> List (Symbol "do" :: body))] in - step_sf_define (List [Symbol fname; fn_form]) (env) (kont) - | _ -> step_sf_define (args) (env) (kont) -) else (if sx_truthy ((prim_call "=" [name; (String "defcomp")])) then (make_cek_value ((sf_defcomp (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defisland")])) then (make_cek_value ((sf_defisland (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defmacro")])) then (make_cek_value ((sf_defmacro (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "begin")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "do")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "quote")])) then (make_cek_value ((if sx_truthy ((empty_p (args))) then Nil else (first (args)))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "quasiquote")])) then (make_cek_value ((qq_expand ((first (args))) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "->")])) then (step_sf_thread_first (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "set!")])) then (step_sf_set_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "letrec")])) then (step_sf_letrec (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "reset")])) then (step_sf_reset (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "shift")])) then (step_sf_shift (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "deref")])) then (step_sf_deref (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "scope")])) then (step_sf_scope (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "provide")])) then (step_sf_provide (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "dynamic-wind")])) then (make_cek_value ((sf_dynamic_wind (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "map")])) then (step_ho_map (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "map-indexed")])) then (step_ho_map_indexed (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "filter")])) then (step_ho_filter (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "reduce")])) then (step_ho_reduce (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "some")])) then (step_ho_some (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "every?")])) then (step_ho_every (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "for-each")])) then (step_ho_for_each (args) (env) (kont)) else (if sx_truthy ((prim_call "has-key?" [custom_special_forms; name])) then (make_cek_value ((cek_call ((get (custom_special_forms) (name))) (List [args; env]))) (env) (kont)) else (if sx_truthy ((let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_macro ((env_get (env) (name)))))) then (let mac = (env_get (env) (name)) in (make_cek_state ((expand_macro (mac) (args) (env))) (env) (kont))) else (if sx_truthy ((let _and = render_check in if not (sx_truthy _and) then _and else (cek_call (render_check) (List [expr; env])))) then (make_cek_value ((cek_call (render_fn) (List [expr; env]))) (env) (kont)) else (step_eval_call (head) (args) (env) (kont))))))))))))))))))))))))))))))))))))))))))) else (step_eval_call (head) (args) (env) (kont))))) + (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")])) 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))))) + +(* match-find-clause *) +and match_find_clause val' clauses env = + (if sx_truthy ((empty_p (clauses))) then Nil else (let clause = (first (clauses)) in let pattern = (first (clause)) in let body = (nth (clause) ((Number 1.0))) in let local = (env_extend (env)) in (if sx_truthy ((match_pattern (pattern) (val') (local))) then (List [local; body]) else (match_find_clause (val') ((rest (clauses))) (env))))) + +(* match-pattern *) +and match_pattern pattern value env = + (if sx_truthy ((prim_call "=" [pattern; (Symbol "_")])) then (Bool true) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (pattern)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "?")])))) then (let pred = (trampoline ((eval_expr ((nth (pattern) ((Number 1.0)))) (env)))) in (cek_call (pred) ((List [value])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (pattern)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "quote")])))) then (prim_call "=" [value; (nth (pattern) ((Number 1.0)))]) else (if sx_truthy ((symbol_p (pattern))) then (let () = ignore ((env_bind env (sx_to_string (symbol_name (pattern))) value)) in (Bool true)) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (list_p (value)))) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(len (pattern)); (len (value))])))))) then (Bool false) else (let pairs = (prim_call "zip" [pattern; value]) in (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list pairs))))) else (prim_call "=" [pattern; value])))))) + +(* step-sf-match *) +and step_sf_match args env kont = + (let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (raise (Eval_error (value_to_str (String (sx_str [(String "match: no clause matched "); (inspect (val'))]))))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont))))) + +(* step-sf-handler-bind *) +and step_sf_handler_bind args env kont = + (let handler_specs = (first (args)) in let body = (rest (args)) in let handlers = (List (List.map (fun spec -> (List [(trampoline ((eval_expr ((first (spec))) (env)))); (trampoline ((eval_expr ((nth (spec) ((Number 1.0)))) (env))))])) (sx_to_list handler_specs))) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (env) (kont)) else (make_cek_state ((first (body))) (env) ((kont_push ((make_handler_frame (handlers) ((rest (body))) (env))) (kont)))))) + +(* step-sf-restart-case *) +and step_sf_restart_case args env kont = + (let body = (first (args)) in let restart_specs = (rest (args)) in let restarts = (List (List.map (fun spec -> (List [(if sx_truthy ((symbol_p ((first (spec))))) then (symbol_name ((first (spec)))) else (first (spec))); (nth (spec) ((Number 1.0))); (nth (spec) ((Number 2.0)))])) (sx_to_list restart_specs))) in (make_cek_state (body) (env) ((kont_push ((make_restart_frame (restarts) ((List [])) (env))) (kont))))) + +(* step-sf-signal *) +and step_sf_signal args env kont = + (let condition = (trampoline ((eval_expr ((first (args))) (env)))) in let handler_fn = (kont_find_handler (kont) (condition)) in (if sx_truthy ((is_nil (handler_fn))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Unhandled condition: "); (inspect (condition))]))))) else (continue_with_call (handler_fn) ((List [condition])) (env) ((List [condition])) ((kont_push ((make_signal_return_frame (env) (kont))) (kont)))))) + +(* step-sf-invoke-restart *) +and step_sf_invoke_restart args env kont = + (let restart_name = (let rn = (if sx_truthy ((symbol_p ((first (args))))) then (symbol_name ((first (args)))) else (trampoline ((eval_expr ((first (args))) (env))))) in (if sx_truthy ((symbol_p (rn))) then (symbol_name (rn)) else rn)) in let restart_arg = (if sx_truthy ((prim_call ">=" [(len (args)); (Number 2.0)])) then (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) else Nil) in let found = (kont_find_restart (kont) (restart_name)) in (if sx_truthy ((is_nil (found))) then (raise (Eval_error (value_to_str (String (sx_str [(String "No restart named: "); (inspect (restart_name))]))))) else (let entry = (first (found)) in let restart_frame = (nth (found) ((Number 1.0))) in let rest_kont = (nth (found) ((Number 2.0))) in (let params = (nth (entry) ((Number 1.0))) in let body = (nth (entry) ((Number 2.0))) in let restart_env = (env_extend ((get (restart_frame) ((String "env"))))) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((empty_p (params))))))) then (env_bind restart_env (sx_to_string (first (params))) restart_arg) else Nil)) in (make_cek_state (body) (restart_env) (rest_kont))))))) (* step-sf-if *) and step_sf_if args env kont = @@ -408,7 +434,7 @@ and step_sf_begin args env kont = (* step-sf-let *) and step_sf_let args env kont = - let pairs = ref Nil in (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (make_cek_value ((trampoline ((sf_named_let (args) (env))))) (env) (kont)) else (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in (if sx_truthy ((empty_p (bindings))) then (step_sf_begin (body) (local) (kont)) else (let first_binding = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (first (bindings)) else (List [(first (bindings)); (nth (bindings) ((Number 1.0)))])) in let rest_bindings = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (rest (bindings)) else (let pairs = ref ((List [])) in (let () = ignore ((List.fold_left (fun _acc i -> (pairs := sx_append_b !pairs (List [(nth (bindings) ((prim_call "*" [i; (Number 2.0)]))); (nth (bindings) ((prim_call "inc" [(prim_call "*" [i; (Number 2.0)])])))]); Nil)) Nil (sx_to_list (prim_call "range" [(Number 1.0); (prim_call "/" [(len (bindings)); (Number 2.0)])])))) in !pairs))) in (let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (first_binding)))); (String "symbol")])) then (symbol_name ((first (first_binding)))) else (first (first_binding))) in (make_cek_state ((nth (first_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) (rest_bindings) (body) (local))) (kont))))))))) + let pairs = ref Nil in (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (make_cek_value ((sf_named_let (args) (env))) (env) (kont)) else (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in (if sx_truthy ((empty_p (bindings))) then (step_sf_begin (body) (local) (kont)) else (let first_binding = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (first (bindings)) else (List [(first (bindings)); (nth (bindings) ((Number 1.0)))])) in let rest_bindings = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (rest (bindings)) else (let pairs = ref ((List [])) in (let () = ignore ((List.fold_left (fun _acc i -> (pairs := sx_append_b !pairs (List [(nth (bindings) ((prim_call "*" [i; (Number 2.0)]))); (nth (bindings) ((prim_call "inc" [(prim_call "*" [i; (Number 2.0)])])))]); Nil)) Nil (sx_to_list (prim_call "range" [(Number 1.0); (prim_call "/" [(len (bindings)); (Number 2.0)])])))) in !pairs))) in (let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (first_binding)))); (String "symbol")])) then (symbol_name ((first (first_binding)))) else (first (first_binding))) in (make_cek_state ((nth (first_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) (rest_bindings) (body) (local))) (kont))))))))) (* step-sf-define *) and step_sf_define args env kont = @@ -532,11 +558,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 (if value = Nil then let ctx = match raw_args with List l -> String.concat " " (List.map (fun a -> let s = Sx_types.inspect a in if String.length s > 50 then String.sub s 0 50 ^ ".." else s) l) | _ -> "?" in raise (Eval_error ("Not callable: nil (call-expr: " ^ (if hname <> Nil then Sx_types.inspect hname else "(" ^ ctx ^ ")") ^ ")")) else (continue_with_call (value) ((List [])) (fenv) (raw_args) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (value) ((List [])) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))) else (let new_evaled = (prim_call "append" [evaled; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) (new_evaled)) else Nil)) in (continue_with_call (f) (new_evaled) (fenv) (raw_args) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (f) (new_evaled) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "dict")])) then (let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let fenv = (get (frame) ((String "env"))) in (let last_result = (last (results)) in let completed = (prim_call "append" [(prim_call "slice" [results; (Number 0.0); (prim_call "dec" [(len (results))])]); (List [(List [(first (last_result)); value])])]) in (if sx_truthy ((empty_p (remaining))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun pair -> ignore ((sx_dict_set_b d (first (pair)) (nth (pair) ((Number 1.0)))))) (sx_to_list completed); Nil)) in (make_cek_value (d) (fenv) (rest_k)))) else (let next_entry = (first (remaining)) in (make_cek_state ((nth (next_entry) ((Number 1.0)))) (fenv) ((kont_push ((make_dict_frame ((rest (remaining))) ((prim_call "append" [completed; (List [(List [(first (next_entry))])])])) (fenv))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "ho-setup")])) then (let ho_type = (get (frame) ((String "ho-type"))) in let remaining = (get (frame) ((String "remaining"))) in let evaled = (prim_call "append" [(get (frame) ((String "evaled"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (ho_setup_dispatch (ho_type) (evaled) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_ho_setup_frame (ho_type) ((rest (remaining))) (evaled) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "reset")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [ft; (String "deref")])) then (let val' = value in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy ((is_signal (val'))))))) then (make_cek_value (val') (fenv) (rest_k)) else (if sx_truthy ((has_reactive_reset_frame_p (rest_k))) then (reactive_shift_deref (val') (fenv) (rest_k)) else (let () = ignore ((let ctx = (sx_context ((String "sx-reactive")) (Nil)) in (if sx_truthy (ctx) then (let dep_list = ref ((get (ctx) ((String "deps")))) in let notify_fn = (get (ctx) ((String "notify"))) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!dep_list; val'])))))) then (let () = ignore ((dep_list := sx_append_b !dep_list val'; Nil)) in (signal_add_sub_b (val') (notify_fn))) else Nil)) else Nil))) in (make_cek_value ((signal_value (val'))) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "reactive-reset")])) then (let update_fn = (get (frame) ((String "update-fn"))) in let first_p = (get (frame) ((String "first-render"))) in (let () = ignore ((if sx_truthy ((let _and = update_fn in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (first_p)))))) then (cek_call (update_fn) ((List [value]))) else Nil)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [ft; (String "scope")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop (name))) in (make_cek_value (value) (fenv) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_scope_frame (name) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "provide")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "scope-acc")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((let new_frame = (make_scope_acc_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "emitted") (get (frame) ((String "emitted"))))) in new_frame))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let indexed = (get (frame) ((String "indexed"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (prim_call "append" [results; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let call_args = (if sx_truthy (indexed) then (List [(len (new_results)); (first (remaining))]) else (List [(first (remaining))])) in let next_frame = (if sx_truthy (indexed) then (make_map_indexed_frame (f) ((rest (remaining))) (new_results) (fenv)) else (make_map_frame (f) ((rest (remaining))) (new_results) (fenv))) in (continue_with_call (f) (call_args) (fenv) ((List [])) ((kont_push (next_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "filter")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let current_item = (get (frame) ((String "current-item"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (if sx_truthy (value) then (prim_call "append" [results; (List [current_item])]) else results) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (remaining))) (new_results) ((first (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [ft; (String "reduce")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (continue_with_call (f) ((List [value; (first (remaining))])) (fenv) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "for-each")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (Nil) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "some")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy (value) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_some_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [ft; (String "every")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool true)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_every_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown frame type: "); ft])))))))))))))))))))))))))))))))))) + (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])))))))))))))))))))))))))))))))))))))) (* 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 local = (env_merge ((lambda_closure (f))) (env)) in let () = bind_lambda_params f 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 ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) (kont))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))]))))))))) + (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (make_cek_value ((sx_apply f args)) (env) (kont)) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil)) in (match !jit_call_hook, f with | Some hook, Lambda l when l.l_name <> None -> let args_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in (match hook f args_list with Some result -> make_cek_value result local kont | None -> make_cek_state (lambda_body f) local kont) | _ -> make_cek_state ((lambda_body (f))) (local) (kont)))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_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 = @@ -564,16 +590,60 @@ 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 -(* Wire up as_number trampoline so arithmetic on leaked thunks auto-resolves *) -let () = Sx_primitives.trampoline_hook := !trampoline_fn - -(* Override recursive cek_run with iterative loop *) +(* 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 - while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do - s := cek_step !s + (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 + let k = ref kont in + while (match !k with List (_::_) -> true | _ -> false) do + (match !k with + | List (frame :: rest) -> + (match frame with + | CekFrame f when f.cf_type = "comp-trace" -> + let name = match f.cf_name with String s -> s | _ -> "?" in + let file = match f.cf_env with String s -> s | Nil -> "" | _ -> "" in + trace := (name, file) :: !trace + | Dict d when (match Hashtbl.find_opt d "type" with Some (String "comp-trace") -> true | _ -> false) -> + let name = match Hashtbl.find_opt d "name" with Some (String s) -> s | _ -> "?" in + let file = match Hashtbl.find_opt d "file" with Some (String s) -> s | _ -> "" in + trace := (name, file) :: !trace + | _ -> ()); + k := List rest + | _ -> k := List []) done; - cek_value !s + List.rev !trace + +(* Format a comp-trace into a human-readable string *) +let format_comp_trace trace = + match trace with + | [] -> "" + | entries -> + let lines = List.mapi (fun i (name, file) -> + let prefix = if i = 0 then " in " else " called from " in + if file = "" then prefix ^ "~" ^ name + else prefix ^ "~" ^ name ^ " (" ^ file ^ ")" + ) entries in + " +" ^ String.concat " +" lines + +(* Enhance an error message with component trace *) +let enhance_error_with_trace msg = + let trace = collect_comp_trace !_last_error_kont in + _last_error_kont := Nil; + msg ^ (format_comp_trace trace) diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index f0e85b10..796a62e0 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -102,7 +102,7 @@ let get_val container key = | "match-val" -> f.cf_extra | "current-item" -> f.cf_extra | "update-fn" -> f.cf_extra | "head-name" -> f.cf_extra | "emitted" -> f.cf_extra2 | "effect-list" -> f.cf_extra2 - | "first-render" -> f.cf_extra2 + | "first-render" -> f.cf_extra2 | "file" -> f.cf_env | _ -> Nil) | Dict d, String k -> dict_get d k | Dict d, Keyword k -> dict_get d k diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index 06592e8c..1e1f4cac 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -111,6 +111,7 @@ and component = { c_body : value; c_closure : env; c_affinity : string; (** "auto" | "client" | "server" *) + mutable c_file : string option; (** Source file path *) mutable c_compiled : vm_closure option; (** Lazy JIT cache *) } @@ -120,6 +121,7 @@ and island = { i_has_children : bool; i_body : value; i_closure : env; + mutable i_file : string option; (** Source file path *) } and macro = { @@ -287,7 +289,7 @@ let make_component name params has_children body closure affinity = Component { c_name = n; c_params = ps; c_has_children = hc; c_body = body; c_closure = unwrap_env_val closure; c_affinity = aff; - c_compiled = None; + c_file = None; c_compiled = None; } let make_island name params has_children body closure = @@ -297,6 +299,7 @@ let make_island name params has_children body closure = Island { i_name = n; i_params = ps; i_has_children = hc; i_body = body; i_closure = unwrap_env_val closure; + i_file = None; } let make_macro params rest_param body closure name = @@ -400,6 +403,19 @@ let component_name = function | Island i -> String i.i_name | v -> raise (Eval_error ("Expected component, got " ^ type_of v)) +let component_file = function + | Component c -> (match c.c_file with Some f -> String f | None -> Nil) + | Island i -> (match i.i_file with Some f -> String f | None -> Nil) + | _ -> Nil + +let component_set_file v f = + (match v, f with + | Component c, String s -> c.c_file <- Some s + | Island i, String s -> i.i_file <- Some s + | _ -> ()); Nil + +let component_set_file_b = component_set_file + let component_params = function | Component c -> List (List.map (fun s -> String s) c.c_params) | Island i -> List (List.map (fun s -> String s) i.i_params) diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index d6e865cd..9a1c9846 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -202,7 +202,7 @@ "notify-subscribers" "flush-subscribers" "dispose-computed" "continuation?" "continuation-data" "make-cek-continuation" "dynamic-wind-call" "strip-prefix" - "component-set-param-types!" "parse-comp-params" "parse-macro-params" + "component-set-param-types!" "component-file" "component-set-file!" "parse-comp-params" "parse-macro-params" "parse-keyword-args")) (define ml-is-known-name? diff --git a/shared/static/scripts/sx-browser.js b/shared/static/scripts/sx-browser.js index 3515c58f..04af681e 100644 --- a/shared/static/scripts/sx-browser.js +++ b/shared/static/scripts/sx-browser.js @@ -14,7 +14,7 @@ // ========================================================================= var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } }); - var SX_VERSION = "2026-03-28T12:33:20Z"; + var SX_VERSION = "2026-03-28T22:04:02Z"; function isNil(x) { return x === NIL || x === null || x === undefined; } function isSxTruthy(x) { return x !== false && !isNil(x); } @@ -1100,6 +1100,10 @@ PRIMITIVES["make-deref-frame"] = makeDerefFrame; var makeHoSetupFrame = function(hoType, remainingArgs, evaledArgs, env) { return {"ho-type": hoType, "env": env, "evaled": evaledArgs, "type": "ho-setup", "remaining": remainingArgs}; }; PRIMITIVES["make-ho-setup-frame"] = makeHoSetupFrame; + // make-comp-trace-frame + var makeCompTraceFrame = function(name, file) { return {"env": file, "type": "comp-trace", "name": name}; }; +PRIMITIVES["make-comp-trace-frame"] = makeCompTraceFrame; + // frame-type var frameType = function(f) { return get(f, "type"); }; PRIMITIVES["frame-type"] = frameType; @@ -2049,7 +2053,7 @@ PRIMITIVES["step-ho-for-each"] = stepHoForEach; var remaining = get(frame, "remaining"); var fenv = get(frame, "env"); return (isSxTruthy(!isSxTruthy(value)) ? makeCekValue(false, fenv, restK) : (isSxTruthy(isEmpty(remaining)) ? makeCekValue(true, fenv, restK) : continueWithCall(f, [first(remaining)], fenv, [], kontPush(makeEveryFrame(f, rest(remaining), fenv), restK)))); -})() : error((String("Unknown frame type: ") + String(ft))))))))))))))))))))))))))))); +})() : (isSxTruthy((ft == "comp-trace")) ? makeCekValue(value, env, restK) : error((String("Unknown frame type: ") + String(ft)))))))))))))))))))))))))))))); })()); })(); }; PRIMITIVES["step-continue"] = stepContinue; @@ -2078,7 +2082,7 @@ PRIMITIVES["step-continue"] = stepContinue; if (isSxTruthy(componentHasChildren(f))) { envBind(local, "children", children); } - return makeCekState(componentBody(f), local, kont); + return makeCekState(componentBody(f), local, kontPush(makeCompTraceFrame(componentName(f), NIL), kont)); })() : error((String("Not callable: ") + String(inspect(f)))))))); }; PRIMITIVES["continue-with-call"] = continueWithCall; diff --git a/spec/evaluator.sx b/spec/evaluator.sx index b870dabf..e43c7a3c 100644 --- a/spec/evaluator.sx +++ b/spec/evaluator.sx @@ -1,550 +1,477 @@ -;; ========================================================================== -;; evaluator.sx — The SX evaluator specification -;; -;; This is the canonical, single-file specification of SX evaluation. -;; All evaluation goes through the CEK machine (explicit control, -;; environment, and continuation). There is no tree-walk interpreter. -;; -;; Structure: -;; Part 1: CEK frames — state and continuation frame constructors -;; Part 2: Evaluation utilities — lambda/component call, keyword arg -;; parsing, macro expansion, quasiquote, definition forms -;; Part 3: CEK machine — step function, frame dispatch, call dispatch -;; -;; The evaluator is written in a restricted subset of SX that bootstrap -;; compilers (JS, Python) can transpile to native code. -;; -;; Platform interface (must be provided by each host): -;; See Part 2 section headers for type constructors, env operations, -;; and rendering primitives. -;; ========================================================================== +(define make-cek-state (fn (control env kont) {:control control :env env :kont kont :value nil :phase "eval"})) +(define make-cek-value (fn (value env kont) {:control nil :env env :kont kont :value value :phase "continue"})) -;; ************************************************************************** -;; Part 1: CEK Frames — state, continuation, and frame constructors -;; ************************************************************************** +(define + cek-terminal? + (fn + (state) + (and (= (get state "phase") "continue") (empty? (get state "kont"))))) -;; -------------------------------------------------------------------------- -;; 1. CEK State constructors -;; -------------------------------------------------------------------------- +(define cek-control (fn (s) (get s "control"))) -(define make-cek-state - (fn (control env kont) - {:control control :env env :kont kont :phase "eval" :value nil})) +(define cek-env (fn (s) (get s "env"))) -(define make-cek-value - (fn (value env kont) - {:control nil :env env :kont kont :phase "continue" :value value})) +(define cek-kont (fn (s) (get s "kont"))) -(define cek-terminal? - (fn (state) - (and (= (get state "phase") "continue") - (empty? (get state "kont"))))) +(define cek-phase (fn (s) (get s "phase"))) -(define cek-control (fn (s) (get s "control"))) -(define cek-env (fn (s) (get s "env"))) -(define cek-kont (fn (s) (get s "kont"))) -(define cek-phase (fn (s) (get s "phase"))) -(define cek-value (fn (s) (get s "value"))) +(define cek-value (fn (s) (get s "value"))) +(define make-if-frame (fn (then-expr else-expr env) {:else else-expr :env env :type "if" :then then-expr})) -;; -------------------------------------------------------------------------- -;; 2. Frame constructors -;; -------------------------------------------------------------------------- -;; Each frame type is a dict with a "type" key and frame-specific data. +(define make-when-frame (fn (body-exprs env) {:body body-exprs :env env :type "when"})) -;; IfFrame: waiting for condition value -;; After condition evaluates, choose then or else branch -(define make-if-frame - (fn (then-expr else-expr env) - {:type "if" :then then-expr :else else-expr :env env})) +(define make-begin-frame (fn (remaining env) {:env env :type "begin" :remaining remaining})) -;; WhenFrame: waiting for condition value -;; If truthy, evaluate body exprs sequentially -(define make-when-frame - (fn (body-exprs env) - {:type "when" :body body-exprs :env env})) +(define make-let-frame (fn (name remaining body local) {:body body :env local :type "let" :remaining remaining :name name})) -;; BeginFrame: sequential evaluation -;; Remaining expressions to evaluate after current one -(define make-begin-frame - (fn (remaining env) - {:type "begin" :remaining remaining :env env})) +(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})) -;; LetFrame: binding evaluation in progress -;; name = current binding name, remaining = remaining (name val) pairs -;; body = body expressions to evaluate after all bindings -(define make-let-frame - (fn (name remaining body local) - {:type "let" :name name :remaining remaining :body body :env local})) +(define make-set-frame (fn (name env) {:env env :type "set" :name name})) -;; DefineFrame: waiting for value to bind -(define make-define-frame - (fn (name env has-effects effect-list) - {:type "define" :name name :env env - :has-effects has-effects :effect-list effect-list})) +(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})) -;; SetFrame: waiting for value to assign -(define make-set-frame - (fn (name env) - {:type "set" :name name :env env})) +(define make-call-frame (fn (f args env) {:args args :env env :type "call" :f f})) -;; ArgFrame: evaluating function arguments -;; f = function value (already evaluated), evaled = already evaluated args -;; remaining = remaining arg expressions -(define make-arg-frame - (fn (f evaled remaining env raw-args head-name) - {:type "arg" :f f :evaled evaled :remaining remaining :env env - :raw-args raw-args :head-name (or head-name nil)})) +(define make-cond-frame (fn (remaining env scheme?) {:scheme scheme? :env env :type "cond" :remaining remaining})) -;; CallFrame: about to call with fully evaluated args -(define make-call-frame - (fn (f args env) - {:type "call" :f f :args args :env env})) +(define make-case-frame (fn (match-val remaining env) {:match-val match-val :env env :type "case" :remaining remaining})) -;; CondFrame: evaluating cond clauses -(define make-cond-frame - (fn (remaining env scheme?) - {:type "cond" :remaining remaining :env env :scheme scheme?})) +(define make-thread-frame (fn (remaining env) {:env env :type "thread" :remaining remaining})) -;; CaseFrame: evaluating case clauses -(define make-case-frame - (fn (match-val remaining env) - {:type "case" :match-val match-val :remaining remaining :env env})) +(define make-map-frame (fn (f remaining results env) {:indexed false :env env :results results :type "map" :f f :remaining remaining})) -;; ThreadFirstFrame: pipe threading -(define make-thread-frame - (fn (remaining env) - {:type "thread" :remaining remaining :env env})) +(define make-map-indexed-frame (fn (f remaining results env) {:indexed true :env env :results results :type "map" :f f :remaining remaining})) -;; MapFrame: higher-order map/map-indexed in progress -(define make-map-frame - (fn (f remaining results env) - {:type "map" :f f :remaining remaining :results results :env env :indexed false})) +(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})) -(define make-map-indexed-frame - (fn (f remaining results env) - {:type "map" :f f :remaining remaining :results results :env env :indexed true})) +(define make-reduce-frame (fn (f remaining env) {:env env :type "reduce" :f f :remaining remaining})) -;; FilterFrame: higher-order filter in progress -(define make-filter-frame - (fn (f remaining results current-item env) - {:type "filter" :f f :remaining remaining :results results - :current-item current-item :env env})) +(define make-for-each-frame (fn (f remaining env) {:env env :type "for-each" :f f :remaining remaining})) -;; ReduceFrame: higher-order reduce in progress -(define make-reduce-frame - (fn (f remaining env) - {:type "reduce" :f f :remaining remaining :env env})) +(define make-some-frame (fn (f remaining env) {:env env :type "some" :f f :remaining remaining})) -;; ForEachFrame: higher-order for-each in progress -(define make-for-each-frame - (fn (f remaining env) - {:type "for-each" :f f :remaining remaining :env env})) +(define make-every-frame (fn (f remaining env) {:env env :type "every" :f f :remaining remaining})) -;; SomeFrame: higher-order some (short-circuit on first truthy) -(define make-some-frame - (fn (f remaining env) - {:type "some" :f f :remaining remaining :env env})) +(define make-scope-frame (fn (name remaining env) {:env env :type "scope" :remaining remaining :name name})) -;; EveryFrame: higher-order every? (short-circuit on first falsy) -(define make-every-frame - (fn (f remaining env) - {:type "every" :f f :remaining remaining :env env})) +(define make-provide-frame (fn (name value remaining env) {:env env :value value :type "provide" :remaining remaining :name name})) -;; ScopeFrame: remaining body expressions for scope special form -(define make-scope-frame - (fn (name remaining env) - {:type "scope" :name name :remaining remaining :env env})) +(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})) -;; ProvideFrame: dynamic variable binding (context reads this from kont) -(define make-provide-frame - (fn (name value remaining env) - {:type "provide" :name name :value value :remaining remaining :env env})) +(define make-reset-frame (fn (env) {:env env :type "reset"})) -;; ScopeAccFrame: accumulator scope (emit! appends, emitted reads) -(define make-scope-acc-frame - (fn (name value remaining env) - {:type "scope-acc" :name name :value (or value nil) - :emitted (list) :remaining remaining :env env})) +(define make-dict-frame (fn (remaining results env) {:env env :results results :type "dict" :remaining remaining})) -;; ResetFrame: delimiter for shift/reset continuations -(define make-reset-frame - (fn (env) - {:type "reset" :env env})) +(define make-and-frame (fn (remaining env) {:env env :type "and" :remaining remaining})) -;; DictFrame: evaluating dict values -(define make-dict-frame - (fn (remaining results env) - {:type "dict" :remaining remaining :results results :env env})) +(define make-or-frame (fn (remaining env) {:env env :type "or" :remaining remaining})) -;; AndFrame: short-circuit and -(define make-and-frame - (fn (remaining env) - {:type "and" :remaining remaining :env env})) +(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})) -;; OrFrame: short-circuit or -(define make-or-frame - (fn (remaining env) - {:type "or" :remaining remaining :env env})) +(define + make-reactive-reset-frame + (fn (env update-fn first-render?) {:first-render first-render? :update-fn update-fn :env env :type "reactive-reset"})) -;; QuasiquoteFrame (not a real frame — QQ is handled specially) +(define make-deref-frame (fn (env) {:env env :type "deref"})) -;; DynamicWindFrame: phases of dynamic-wind -(define make-dynamic-wind-frame - (fn (phase body-thunk after-thunk env) - {:type "dynamic-wind" :phase phase - :body-thunk body-thunk :after-thunk after-thunk :env env})) +(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})) -;; ReactiveResetFrame: delimiter for reactive deref-as-shift -;; Carries an update-fn that gets called with new values on re-render. -(define make-reactive-reset-frame - (fn (env update-fn first-render?) - {:type "reactive-reset" :env env :update-fn update-fn - :first-render first-render?})) +(define make-comp-trace-frame (fn (name file) {:env file :type "comp-trace" :name name})) -;; DerefFrame: awaiting evaluation of deref's argument -(define make-deref-frame - (fn (env) - {:type "deref" :env env})) +(define + kont-collect-comp-trace + (fn + (kont) + (if + (empty? kont) + (list) + (let + ((frame (first kont))) + (if + (= (frame-type frame) "comp-trace") + (cons {:file (get frame "file") :name (get frame "name")} (kont-collect-comp-trace (rest kont))) + (kont-collect-comp-trace (rest kont))))))) -;; HoSetupFrame: staged evaluation of higher-order form arguments -;; ho-type is "map", "filter", "reduce", etc. -;; Evaluates args one at a time, then dispatches to the iteration frame. -(define make-ho-setup-frame - (fn (ho-type remaining-args evaled-args env) - {:type "ho-setup" :ho-type ho-type :remaining remaining-args - :evaled evaled-args :env env})) +(define make-handler-frame (fn (handlers remaining env) {:env env :type "handler" :f handlers :remaining remaining})) +(define make-restart-frame (fn (restarts remaining env) {:env env :type "restart" :f restarts :remaining remaining})) -;; -------------------------------------------------------------------------- -;; 3. Frame accessors -;; -------------------------------------------------------------------------- +(define make-signal-return-frame (fn (env saved-kont) {:env env :type "signal-return" :f saved-kont})) + +(define + find-matching-handler + (fn + (handlers condition) + (if + (empty? handlers) + nil + (let + ((pair (first handlers))) + (let + ((pred (first pair)) (handler-fn (nth pair 1))) + (if + (cek-call pred (list condition)) + handler-fn + (find-matching-handler (rest handlers) condition))))))) + +(define + kont-find-handler + (fn + (kont condition) + (if + (empty? kont) + nil + (let + ((frame (first kont))) + (if + (= (frame-type frame) "handler") + (let + ((match (find-matching-handler (get frame "f") condition))) + (if + (nil? match) + (kont-find-handler (rest kont) condition) + match)) + (kont-find-handler (rest kont) condition)))))) + +(define + find-named-restart + (fn + (restarts name) + (if + (empty? restarts) + nil + (let + ((entry (first restarts))) + (if + (= (first entry) name) + entry + (find-named-restart (rest restarts) name)))))) + +(define + kont-find-restart + (fn + (kont name) + (if + (empty? kont) + nil + (let + ((frame (first kont))) + (if + (= (frame-type frame) "restart") + (let + ((match (find-named-restart (get frame "f") name))) + (if + (nil? match) + (kont-find-restart (rest kont) name) + (list match frame (rest kont)))) + (kont-find-restart (rest kont) name)))))) (define frame-type (fn (f) (get f "type"))) +(define kont-push (fn (frame kont) (cons frame kont))) -;; -------------------------------------------------------------------------- -;; 4. Continuation operations -;; -------------------------------------------------------------------------- +(define kont-top (fn (kont) (first kont))) -(define kont-push - (fn (frame kont) (cons frame kont))) +(define kont-pop (fn (kont) (rest kont))) -(define kont-top - (fn (kont) (first kont))) +(define kont-empty? (fn (kont) (empty? kont))) -(define kont-pop - (fn (kont) (rest kont))) - -(define kont-empty? - (fn (kont) (empty? kont))) - - -;; -------------------------------------------------------------------------- -;; 5. CEK shift/reset support -;; -------------------------------------------------------------------------- -;; shift captures all frames up to the nearest ResetFrame. -;; reset pushes a ResetFrame. - -(define kont-capture-to-reset - (fn (kont) - ;; Returns (captured-frames remaining-kont). - ;; captured-frames: frames from top up to (not including) ResetFrame. - ;; remaining-kont: frames after ResetFrame. - ;; Stops at either "reset" or "reactive-reset" frames. - (define scan - (fn (k captured) - (if (empty? k) +(define + kont-capture-to-reset + (fn + (kont) + (define + scan + (fn + (k captured) + (if + (empty? k) (error "shift without enclosing reset") - (let ((frame (first k))) - (if (or (= (frame-type frame) "reset") - (= (frame-type frame) "reactive-reset")) + (let + ((frame (first k))) + (if + (or + (= (frame-type frame) "reset") + (= (frame-type frame) "reactive-reset")) (list captured (rest k)) (scan (rest k) (append captured (list frame)))))))) (scan kont (list)))) -;; Walk kont for nearest ProvideFrame with matching name -(define kont-find-provide - (fn (kont name) - (if (empty? kont) nil - (let ((frame (first kont))) - (if (and (= (frame-type frame) "provide") - (= (get frame "name") name)) +(define + kont-find-provide + (fn + (kont name) + (if + (empty? kont) + nil + (let + ((frame (first kont))) + (if + (and + (= (frame-type frame) "provide") + (= (get frame "name") name)) frame (kont-find-provide (rest kont) name)))))) -;; Walk kont for nearest ScopeAccFrame with matching name -(define kont-find-scope-acc - (fn (kont name) - (if (empty? kont) nil - (let ((frame (first kont))) - (if (and (= (frame-type frame) "scope-acc") - (= (get frame "name") name)) +(define + kont-find-scope-acc + (fn + (kont name) + (if + (empty? kont) + nil + (let + ((frame (first kont))) + (if + (and + (= (frame-type frame) "scope-acc") + (= (get frame "name") name)) frame (kont-find-scope-acc (rest kont) name)))))) -;; Check if a ReactiveResetFrame exists anywhere in the continuation -(define has-reactive-reset-frame? - (fn (kont) - (if (empty? kont) false - (if (= (frame-type (first kont)) "reactive-reset") true +(define + has-reactive-reset-frame? + (fn + (kont) + (if + (empty? kont) + false + (if + (= (frame-type (first kont)) "reactive-reset") + true (has-reactive-reset-frame? (rest kont)))))) -;; Capture frames up to nearest ReactiveResetFrame. -;; Returns (captured-frames, reset-frame, remaining-kont). -(define kont-capture-to-reactive-reset - (fn (kont) - (define scan - (fn (k captured) - (if (empty? k) +(define + kont-capture-to-reactive-reset + (fn + (kont) + (define + scan + (fn + (k captured) + (if + (empty? k) (error "reactive deref without enclosing reactive-reset") - (let ((frame (first k))) - (if (= (frame-type frame) "reactive-reset") + (let + ((frame (first k))) + (if + (= (frame-type frame) "reactive-reset") (list captured frame (rest k)) (scan (rest k) (append captured (list frame)))))))) (scan kont (list)))) - -;; -------------------------------------------------------------------------- -;; Extension points — custom special forms and render dispatch -;; -------------------------------------------------------------------------- -;; -;; Extensions (web forms, type system, etc.) register handlers here. -;; The evaluator calls these from step-eval-list after core forms. - (define *custom-special-forms* (dict)) -(define register-special-form! - (fn ((name :as string) handler) +(define + register-special-form! + (fn + ((name :as string) handler) (dict-set! *custom-special-forms* name handler))) -;; Render dispatch — installed by web adapters, nil when no renderer active. -;; *render-check*: (expr env) → boolean — should this expression be rendered? -;; *render-fn*: (expr env) → value — render and return result (define *render-check* nil) + (define *render-fn* nil) - -;; ************************************************************************** -;; Part 2: Evaluation Utilities -;; ************************************************************************** - -;; -------------------------------------------------------------------------- -;; 1. Types -;; -------------------------------------------------------------------------- -;; -;; The evaluator operates on these value types: -;; -;; number — integer or float -;; string — double-quoted text -;; boolean — true / false -;; nil — singleton null -;; symbol — unquoted identifier (e.g. div, ~card, map) -;; keyword — colon-prefixed key (e.g. :class, :id) -;; list — ordered sequence (also used as code) -;; dict — string-keyed hash map -;; lambda — closure: {params, body, closure-env, name?} -;; macro — AST transformer: {params, rest-param, body, closure-env} -;; component — UI component: {name, params, has-children, body, closure-env} -;; island — reactive component: like component but with island flag -;; thunk — deferred eval for TCO: {expr, env} -;; -;; Each target must provide: -;; (type-of x) → one of the strings above -;; (make-lambda ...) → platform Lambda value -;; (make-component ..) → platform Component value -;; (make-island ...) → platform Island value (component + island flag) -;; (make-macro ...) → platform Macro value -;; (make-thunk ...) → platform Thunk value -;; -;; These are declared in platform.sx and implemented per target. -;; -------------------------------------------------------------------------- - - -;; -------------------------------------------------------------------------- -;; 2. Trampoline — tail-call optimization -;; -------------------------------------------------------------------------- - -(define trampoline - (fn ((val :as any)) - ;; Iteratively resolve thunks until we get an actual value. - ;; Each target implements thunk? and thunk-expr/thunk-env. - (let ((result val)) +(define + trampoline + (fn + ((val :as any)) + (let + ((result val)) (do - ;; Loop while result is a thunk - ;; Note: this is pseudo-iteration — bootstrap compilers convert - ;; this tail-recursive form to a while loop. - (if (thunk? result) + (if + (thunk? result) (trampoline (eval-expr (thunk-expr result) (thunk-env result))) result))))) - -;; -------------------------------------------------------------------------- -;; 2b. Strict mode — runtime type checking for primitive calls -;; -------------------------------------------------------------------------- -;; -;; When *strict* is true, primitive calls check arg types before dispatch. -;; The primitive param type registry maps name → {positional [[name type]...], -;; rest-type type-or-nil}. Stored in *prim-param-types* in the env. -;; -;; Strict mode is off by default. Hosts can enable it at startup via: -;; (set-strict! true) -;; (set-prim-param-types! types-dict) - (define *strict* false) -(define set-strict! - (fn (val) - (set! *strict* val))) +(define set-strict! (fn (val) (set! *strict* val))) (define *prim-param-types* nil) -(define set-prim-param-types! - (fn (types) - (set! *prim-param-types* types))) +(define set-prim-param-types! (fn (types) (set! *prim-param-types* types))) -(define value-matches-type? - (fn (val expected-type) - ;; Check if a runtime value matches a declared type string. +(define + value-matches-type? + (fn + (val expected-type) (cond - (= expected-type "any") true - (= expected-type "number") (number? val) - (= expected-type "string") (string? val) - (= expected-type "boolean") (boolean? val) - (= expected-type "nil") (nil? val) - (= expected-type "list") (list? val) - (= expected-type "dict") (dict? val) - (= expected-type "lambda") (lambda? val) - (= expected-type "symbol") (= (type-of val) "symbol") - (= expected-type "keyword") (= (type-of val) "keyword") - ;; Nullable: "string?" means string or nil - (and (string? expected-type) - (ends-with? expected-type "?")) - (or (nil? val) - (value-matches-type? val (slice expected-type 0 (- (string-length expected-type) 1)))) + (= expected-type "any") + true + (= expected-type "number") + (number? val) + (= expected-type "string") + (string? val) + (= expected-type "boolean") + (boolean? val) + (= expected-type "nil") + (nil? val) + (= expected-type "list") + (list? val) + (= expected-type "dict") + (dict? val) + (= expected-type "lambda") + (lambda? val) + (= expected-type "symbol") + (= (type-of val) "symbol") + (= expected-type "keyword") + (= (type-of val) "keyword") + (and (string? expected-type) (ends-with? expected-type "?")) + (or + (nil? val) + (value-matches-type? + val + (slice expected-type 0 (- (string-length expected-type) 1)))) :else true))) -(define strict-check-args - (fn (name args) - ;; Check args against *prim-param-types* if strict mode is on. - ;; Throws on type violation. No-op if *strict* is false or types not registered. - (when (and *strict* *prim-param-types*) - (let ((spec (get *prim-param-types* name))) - (when spec - (let ((positional (get spec "positional")) - (rest-type (get spec "rest-type"))) - ;; Check positional params - (when positional +(define + strict-check-args + (fn + (name args) + (when + (and *strict* *prim-param-types*) + (let + ((spec (get *prim-param-types* name))) + (when + spec + (let + ((positional (get spec "positional")) + (rest-type (get spec "rest-type"))) + (when + positional (for-each - (fn (pair) - (let ((idx (first pair)) - (param (nth pair 1)) - (p-name (first param)) - (p-type (nth param 1))) - (when (< idx (len args)) - (let ((val (nth args idx))) - (when (not (value-matches-type? val p-type)) - (error (str "Type error: " name " expected " p-type - " for param " p-name - ", got " (type-of val) " (" (str val) ")"))))))) + (fn + (pair) + (let + ((idx (first pair)) + (param (nth pair 1)) + (p-name (first param)) + (p-type (nth param 1))) + (when + (< idx (len args)) + (let + ((val (nth args idx))) + (when + (not (value-matches-type? val p-type)) + (error + (str + "Type error: " + name + " expected " + p-type + " for param " + p-name + ", got " + (type-of val) + " (" + (str val) + ")"))))))) (map-indexed (fn (i p) (list i p)) positional))) - ;; Check rest args - (when (and rest-type (> (len args) (len (or positional (list))))) + (when + (and rest-type (> (len args) (len (or positional (list))))) (for-each - (fn (pair) - (let ((idx (first pair)) - (val (nth pair 1))) - (when (not (value-matches-type? val rest-type)) - (error (str "Type error: " name " expected " rest-type - " for rest arg " idx - ", got " (type-of val) " (" (str val) ")"))))) - (map-indexed (fn (i v) (list i v)) + (fn + (pair) + (let + ((idx (first pair)) (val (nth pair 1))) + (when + (not (value-matches-type? val rest-type)) + (error + (str + "Type error: " + name + " expected " + rest-type + " for rest arg " + idx + ", got " + (type-of val) + " (" + (str val) + ")"))))) + (map-indexed + (fn (i v) (list i v)) (slice args (len (or positional (list))))))))))))) +(define eval-expr (fn (expr (env :as dict)) nil)) -;; -------------------------------------------------------------------------- -;; 3. Core evaluator — stub (overridden by CEK in fixups) -;; -------------------------------------------------------------------------- -;; -;; eval-expr and trampoline are defined as stubs here so the transpiler -;; creates the variable declarations. The CEK fixups override them with: -;; eval-expr = (expr, env) → cek-run(make-cek-state(expr, env, [])) -;; trampoline = (val) → if thunk? then eval-expr(thunk-expr, thunk-env) else val -;; All evaluation goes through the CEK machine. - -;; eval-expr: forward declaration — redefined at end of file after cek-run exists. -;; This stub is needed so functions between here and Part 3 can reference eval-expr. -(define eval-expr - (fn (expr (env :as dict)) nil)) - - - - -;; -------------------------------------------------------------------------- -;; 5. Function / lambda / component call -;; -------------------------------------------------------------------------- - -(define call-lambda - (fn ((f :as lambda) (args :as list) (caller-env :as dict)) - (let ((params (lambda-params f)) - (local (env-merge (lambda-closure f) caller-env))) - ;; Too many args is an error; too few pads with nil - (if (> (len args) (len params)) - (error (str (or (lambda-name f) "lambda") - " expects " (len params) " args, got " (len args))) +(define + call-lambda + (fn + ((f :as lambda) (args :as list) (caller-env :as dict)) + (let + ((params (lambda-params f)) + (local (env-merge (lambda-closure f) caller-env))) + (if + (> (len args) (len params)) + (error + (str + (or (lambda-name f) "lambda") + " expects " + (len params) + " args, got " + (len args))) (do - ;; Bind params — provided args first, then nil for missing (for-each (fn (pair) (env-bind! local (first pair) (nth pair 1))) (zip params args)) (for-each (fn (p) (env-bind! local p nil)) (slice params (len args))) - ;; Return thunk for TCO (make-thunk (lambda-body f) local)))))) - -(define call-component - (fn ((comp :as component) (raw-args :as list) (env :as dict)) - ;; Parse keyword args and children from unevaluated arg list - (let ((parsed (parse-keyword-args raw-args env)) - (kwargs (first parsed)) - (children (nth parsed 1)) - (local (env-merge (component-closure comp) env))) - ;; Bind keyword params +(define + call-component + (fn + ((comp :as component) (raw-args :as list) (env :as dict)) + (let + ((parsed (parse-keyword-args raw-args env)) + (kwargs (first parsed)) + (children (nth parsed 1)) + (local (env-merge (component-closure comp) env))) (for-each (fn (p) (env-bind! local p (or (dict-get kwargs p) nil))) (component-params comp)) - ;; Bind children if component accepts them - (when (component-has-children? comp) + (when + (component-has-children? comp) (env-bind! local "children" children)) - ;; Return thunk — body evaluated in local env (make-thunk (component-body comp) local)))) - -(define parse-keyword-args - (fn ((raw-args :as list) (env :as dict)) - ;; Walk args: keyword + next-val → kwargs dict, else → children list - (let ((kwargs (dict)) - (children (list)) - (i 0)) - ;; Iterative parse — bootstrap converts to while loop +(define + parse-keyword-args + (fn + ((raw-args :as list) (env :as dict)) + (let + ((kwargs (dict)) (children (list)) (i 0)) (reduce - (fn (state arg) - (let ((idx (get state "i")) - (skip (get state "skip"))) - (if skip - ;; This arg was consumed as a keyword value + (fn + (state arg) + (let + ((idx (get state "i")) (skip (get state "skip"))) + (if + skip (assoc state "skip" false "i" (inc idx)) - (if (and (= (type-of arg) "keyword") - (< (inc idx) (len raw-args))) - ;; Keyword: evaluate next arg and store + (if + (and + (= (type-of arg) "keyword") + (< (inc idx) (len raw-args))) (do - (dict-set! kwargs (keyword-name arg) + (dict-set! + kwargs + (keyword-name arg) (trampoline (eval-expr (nth raw-args (inc idx)) env))) (assoc state "skip" true "i" (inc idx))) - ;; Positional: evaluate and add to children (do (append! children (trampoline (eval-expr arg env))) (assoc state "i" (inc idx))))))) @@ -552,1769 +479,2034 @@ raw-args) (list kwargs children)))) +(define + cond-scheme? + (fn + ((clauses :as list)) + (every? (fn (c) (and (= (type-of c) "list") (= (len c) 2))) clauses))) -;; -------------------------------------------------------------------------- -;; 6. Special forms -;; -------------------------------------------------------------------------- -;; — all superseded by CEK step handlers in cek.sx +(define + is-else-clause? + (fn + (test) + (or + (and (= (type-of test) "keyword") (= (keyword-name test) "else")) + (and + (= (type-of test) "symbol") + (or (= (symbol-name test) "else") (= (symbol-name test) ":else")))))) - -;; cond-scheme? — still needed by CEK's step-sf-cond -(define cond-scheme? - (fn ((clauses :as list)) - (every? (fn (c) (and (= (type-of c) "list") (= (len c) 2))) - clauses))) - -;; is-else-clause? — check if a cond/case test is an else marker -(define is-else-clause? - (fn (test) - (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) - (and (= (type-of test) "symbol") - (or (= (symbol-name test) "else") - (= (symbol-name test) ":else")))))) - - -;; Named let: (let name ((x 0) (y 1)) body...) -;; Desugars to a self-recursive lambda called with initial values. -;; The loop name is bound in the body so recursive calls produce TCO thunks. -(define sf-named-let - (fn ((args :as list) (env :as dict)) - (let ((loop-name (symbol-name (first args))) - (bindings (nth args 1)) - (body (slice args 2)) - (params (list)) - (inits (list))) - ;; Extract param names and init expressions - (if (and (= (type-of (first bindings)) "list") - (= (len (first bindings)) 2)) - ;; Scheme-style: ((x 0) (y 1)) +(define + sf-named-let + (fn + ((args :as list) (env :as dict)) + (let + ((loop-name (symbol-name (first args))) + (bindings (nth args 1)) + (body (slice args 2)) + (params (list)) + (inits (list))) + (if + (and + (= (type-of (first bindings)) "list") + (= (len (first bindings)) 2)) (for-each - (fn (binding) - (append! params (if (= (type-of (first binding)) "symbol") - (symbol-name (first binding)) - (first binding))) + (fn + (binding) + (append! + params + (if + (= (type-of (first binding)) "symbol") + (symbol-name (first binding)) + (first binding))) (append! inits (nth binding 1))) bindings) - ;; Clojure-style: (x 0 y 1) (reduce - (fn (acc pair-idx) + (fn + (acc pair-idx) (do - (append! params (if (= (type-of (nth bindings (* pair-idx 2))) "symbol") - (symbol-name (nth bindings (* pair-idx 2))) - (nth bindings (* pair-idx 2)))) + (append! + params + (if + (= (type-of (nth bindings (* pair-idx 2))) "symbol") + (symbol-name (nth bindings (* pair-idx 2))) + (nth bindings (* pair-idx 2)))) (append! inits (nth bindings (inc (* pair-idx 2)))))) nil (range 0 (/ (len bindings) 2)))) - ;; Build loop body (wrap in begin if multiple exprs) - (let ((loop-body (if (= (len body) 1) (first body) - (cons (make-symbol "begin") body))) - (loop-fn (make-lambda params loop-body env))) - ;; Self-reference: loop can call itself by name + (let + ((loop-body (if (= (len body) 1) (first body) (cons (make-symbol "begin") body))) + (loop-fn (make-lambda params loop-body env))) (set-lambda-name! loop-fn loop-name) (env-bind! (lambda-closure loop-fn) loop-name loop-fn) - ;; Evaluate initial values in enclosing env, then call - (let ((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits))) + (let + ((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits))) (call-lambda loop-fn init-vals env)))))) - -(define sf-lambda - (fn ((args :as list) (env :as dict)) - (let ((params-expr (first args)) - (body-exprs (rest args)) - (body (if (= (len body-exprs) 1) - (first body-exprs) - (cons (make-symbol "begin") body-exprs))) - (param-names (map (fn (p) - (cond - (= (type-of p) "symbol") - (symbol-name p) - ;; Annotated param: (name :as type) → extract name - (and (= (type-of p) "list") - (= (len p) 3) - (= (type-of (nth p 1)) "keyword") - (= (keyword-name (nth p 1)) "as")) - (symbol-name (first p)) - :else p)) - params-expr))) +(define + sf-lambda + (fn + ((args :as list) (env :as dict)) + (let + ((params-expr (first args)) + (body-exprs (rest args)) + (body + (if + (= (len body-exprs) 1) + (first body-exprs) + (cons (make-symbol "begin") body-exprs))) + (param-names + (map + (fn + (p) + (cond + (= (type-of p) "symbol") + (symbol-name p) + (and + (= (type-of p) "list") + (= (len p) 3) + (= (type-of (nth p 1)) "keyword") + (= (keyword-name (nth p 1)) "as")) + (symbol-name (first p)) + :else p)) + params-expr))) (make-lambda param-names body env)))) - -(define sf-defcomp - (fn ((args :as list) (env :as dict)) - ;; (defcomp ~name (params) [:affinity :client|:server] body) - ;; Body is always the last element. Optional keyword annotations - ;; may appear between the params list and the body. - (let ((name-sym (first args)) - (params-raw (nth args 1)) - (body (last args)) - (comp-name (strip-prefix (symbol-name name-sym) "~")) - (parsed (parse-comp-params params-raw)) - (params (first parsed)) - (has-children (nth parsed 1)) - (param-types (nth parsed 2)) - (affinity (defcomp-kwarg args "affinity" "auto"))) - (let ((comp (make-component comp-name params has-children body env affinity)) - (effects (defcomp-kwarg args "effects" nil))) - ;; Store type annotations if any were declared - (when (and (not (nil? param-types)) - (not (empty? (keys param-types)))) +(define + sf-defcomp + (fn + ((args :as list) (env :as dict)) + (let + ((name-sym (first args)) + (params-raw (nth args 1)) + (body (last args)) + (comp-name (strip-prefix (symbol-name name-sym) "~")) + (parsed (parse-comp-params params-raw)) + (params (first parsed)) + (has-children (nth parsed 1)) + (param-types (nth parsed 2)) + (affinity (defcomp-kwarg args "affinity" "auto"))) + (let + ((comp (make-component comp-name params has-children body env affinity)) + (effects (defcomp-kwarg args "effects" nil))) + (when + (and (not (nil? param-types)) (not (empty? (keys param-types)))) (component-set-param-types! comp param-types)) - ;; Store effect annotation if declared - (when (not (nil? effects)) - (let ((effect-list (if (= (type-of effects) "list") - (map (fn (e) (if (= (type-of e) "symbol") - (symbol-name e) (str e))) - effects) - (list (str effects)))) - (effect-anns (if (env-has? env "*effect-annotations*") - (env-get env "*effect-annotations*") - (dict)))) + (when + (not (nil? effects)) + (let + ((effect-list (if (= (type-of effects) "list") (map (fn (e) (if (= (type-of e) "symbol") (symbol-name e) (str e))) effects) (list (str effects)))) + (effect-anns + (if + (env-has? env "*effect-annotations*") + (env-get env "*effect-annotations*") + (dict)))) (dict-set! effect-anns (symbol-name name-sym) effect-list) (env-bind! env "*effect-annotations*" effect-anns))) + (when + (env-has? env "*current-file*") + (component-set-file! comp (env-get env "*current-file*"))) (env-bind! env (symbol-name name-sym) comp) comp)))) -(define defcomp-kwarg - (fn ((args :as list) (key :as string) default) - ;; Search for :key value between params (index 2) and body (last). - (let ((end (- (len args) 1)) - (result default)) +(define + defcomp-kwarg + (fn + ((args :as list) (key :as string) default) + (let + ((end (- (len args) 1)) (result default)) (for-each - (fn (i) - (when (and (= (type-of (nth args i)) "keyword") - (= (keyword-name (nth args i)) key) - (< (+ i 1) end)) - (let ((val (nth args (+ i 1)))) - (set! result (if (= (type-of val) "keyword") - (keyword-name val) val))))) + (fn + (i) + (when + (and + (= (type-of (nth args i)) "keyword") + (= (keyword-name (nth args i)) key) + (< (+ i 1) end)) + (let + ((val (nth args (+ i 1)))) + (set! + result + (if (= (type-of val) "keyword") (keyword-name val) val))))) (range 2 end 1)) result))) -(define parse-comp-params - (fn ((params-expr :as list)) - ;; Parse (&key param1 param2 &children) → (params has-children param-types) - ;; Also accepts &rest as synonym for &children. - ;; Supports typed params: (name :as type) — a 3-element list where - ;; the second element is the keyword :as. Unannotated params get no - ;; type entry. param-types is a dict {name → type-expr} or empty dict. - (let ((params (list)) - (param-types (dict)) - (has-children false) - (in-key false)) +(define + parse-comp-params + (fn + ((params-expr :as list)) + (let + ((params (list)) + (param-types (dict)) + (has-children false) + (in-key false)) (for-each - (fn (p) - (if (and (= (type-of p) "list") - (= (len p) 3) - (= (type-of (first p)) "symbol") - (= (type-of (nth p 1)) "keyword") - (= (keyword-name (nth p 1)) "as")) - ;; Typed param: (name :as type) - (let ((name (symbol-name (first p))) - (ptype (nth p 2))) - ;; Convert type to string if it's a symbol - (let ((type-val (if (= (type-of ptype) "symbol") - (symbol-name ptype) - ptype))) - (when (not has-children) + (fn + (p) + (if + (and + (= (type-of p) "list") + (= (len p) 3) + (= (type-of (first p)) "symbol") + (= (type-of (nth p 1)) "keyword") + (= (keyword-name (nth p 1)) "as")) + (let + ((name (symbol-name (first p))) (ptype (nth p 2))) + (let + ((type-val (if (= (type-of ptype) "symbol") (symbol-name ptype) ptype))) + (when + (not has-children) (append! params name) (dict-set! param-types name type-val)))) - ;; Untyped param or marker - (when (= (type-of p) "symbol") - (let ((name (symbol-name p))) + (when + (= (type-of p) "symbol") + (let + ((name (symbol-name p))) (cond - (= name "&key") (set! in-key true) - (= name "&rest") (set! has-children true) - (= name "&children") (set! has-children true) - has-children nil ;; skip params after &children/&rest - in-key (append! params name) - :else (append! params name)))))) + (= name "&key") + (set! in-key true) + (= name "&rest") + (set! has-children true) + (= name "&children") + (set! has-children true) + has-children + nil + in-key + (append! params name) + :else (append! params name)))))) params-expr) (list params has-children param-types)))) - -(define sf-defisland - (fn ((args :as list) (env :as dict)) - ;; (defisland ~name (params) body...) - ;; Like defcomp but creates an island (reactive component). - ;; Islands have the same calling convention as components but - ;; render with a reactive context on the client. - ;; Multi-expression bodies are wrapped in (begin ...). - (let ((name-sym (first args)) - (params-raw (nth args 1)) - (body-exprs (slice args 2)) - (body (if (= (len body-exprs) 1) - (first body-exprs) - (cons (make-symbol "begin") body-exprs))) - (comp-name (strip-prefix (symbol-name name-sym) "~")) - (parsed (parse-comp-params params-raw)) - (params (first parsed)) - (has-children (nth parsed 1))) - (let ((island (make-island comp-name params has-children body env))) +(define + sf-defisland + (fn + ((args :as list) (env :as dict)) + (let + ((name-sym (first args)) + (params-raw (nth args 1)) + (body-exprs (slice args 2)) + (body + (if + (= (len body-exprs) 1) + (first body-exprs) + (cons (make-symbol "begin") body-exprs))) + (comp-name (strip-prefix (symbol-name name-sym) "~")) + (parsed (parse-comp-params params-raw)) + (params (first parsed)) + (has-children (nth parsed 1))) + (let + ((island (make-island comp-name params has-children body env))) + (when + (env-has? env "*current-file*") + (component-set-file! island (env-get env "*current-file*"))) (env-bind! env (symbol-name name-sym) island) island)))) - -(define sf-defmacro - (fn ((args :as list) (env :as dict)) - (let ((name-sym (first args)) - (params-raw (nth args 1)) - (body (nth args 2)) - (parsed (parse-macro-params params-raw)) - (params (first parsed)) - (rest-param (nth parsed 1))) - (let ((mac (make-macro params rest-param body env (symbol-name name-sym)))) +(define + sf-defmacro + (fn + ((args :as list) (env :as dict)) + (let + ((name-sym (first args)) + (params-raw (nth args 1)) + (body (nth args 2)) + (parsed (parse-macro-params params-raw)) + (params (first parsed)) + (rest-param (nth parsed 1))) + (let + ((mac (make-macro params rest-param body env (symbol-name name-sym)))) (env-bind! env (symbol-name name-sym) mac) mac)))) -(define parse-macro-params - (fn ((params-expr :as list)) - ;; Parse (a b &rest rest) → ((a b) rest) - (let ((params (list)) - (rest-param nil)) +(define + parse-macro-params + (fn + ((params-expr :as list)) + (let + ((params (list)) (rest-param nil)) (reduce - (fn (state p) - (if (and (= (type-of p) "symbol") (= (symbol-name p) "&rest")) + (fn + (state p) + (if + (and (= (type-of p) "symbol") (= (symbol-name p) "&rest")) (assoc state "in-rest" true) - (if (get state "in-rest") - (do (set! rest-param (if (= (type-of p) "symbol") - (symbol-name p) p)) - state) - (do (append! params (if (= (type-of p) "symbol") - (symbol-name p) p)) - state)))) + (if + (get state "in-rest") + (do + (set! + rest-param + (if (= (type-of p) "symbol") (symbol-name p) p)) + state) + (do + (append! + params + (if (= (type-of p) "symbol") (symbol-name p) p)) + state)))) (dict "in-rest" false) params-expr) (list params rest-param)))) - -(define qq-expand - (fn (template (env :as dict)) - (if (not (= (type-of template) "list")) +(define + qq-expand + (fn + (template (env :as dict)) + (if + (not (= (type-of template) "list")) template - (if (empty? template) + (if + (empty? template) (list) - (let ((head (first template))) - (if (and (= (type-of head) "symbol") (= (symbol-name head) "unquote")) + (let + ((head (first template))) + (if + (and + (= (type-of head) "symbol") + (= (symbol-name head) "unquote")) (trampoline (eval-expr (nth template 1) env)) - ;; Walk children, handling splice-unquote (reduce - (fn (result item) - (if (and (= (type-of item) "list") - (= (len item) 2) - (= (type-of (first item)) "symbol") - (= (symbol-name (first item)) "splice-unquote")) - (let ((spliced (trampoline (eval-expr (nth item 1) env)))) - (if (= (type-of spliced) "list") + (fn + (result item) + (if + (and + (= (type-of item) "list") + (= (len item) 2) + (= (type-of (first item)) "symbol") + (= (symbol-name (first item)) "splice-unquote")) + (let + ((spliced (trampoline (eval-expr (nth item 1) env)))) + (if + (= (type-of spliced) "list") (concat result spliced) - (if (nil? spliced) result (concat result (list spliced))))) + (if + (nil? spliced) + result + (concat result (list spliced))))) (concat result (list (qq-expand item env))))) (list) template))))))) - -;; -------------------------------------------------------------------------- -;; 6c. letrec — mutually recursive local bindings -;; -------------------------------------------------------------------------- -;; -;; (letrec ((even? (fn (n) (if (= n 0) true (odd? (- n 1))))) -;; (odd? (fn (n) (if (= n 0) false (even? (- n 1)))))) -;; (even? 10)) -;; -;; All bindings are first set to nil in the local env, then all values -;; are evaluated (so they can see each other's names), then lambda -;; closures are patched to include the final bindings. -;; -------------------------------------------------------------------------- - -(define sf-letrec - (fn ((args :as list) (env :as dict)) - (let ((bindings (first args)) - (body (rest args)) - (local (env-extend env)) - (names (list)) - (val-exprs (list))) - ;; First pass: bind all names to nil - (if (and (= (type-of (first bindings)) "list") - (= (len (first bindings)) 2)) - ;; Scheme-style +(define + sf-letrec + (fn + ((args :as list) (env :as dict)) + (let + ((bindings (first args)) + (body (rest args)) + (local (env-extend env)) + (names (list)) + (val-exprs (list))) + (if + (and + (= (type-of (first bindings)) "list") + (= (len (first bindings)) 2)) (for-each - (fn (binding) - (let ((vname (if (= (type-of (first binding)) "symbol") - (symbol-name (first binding)) - (first binding)))) + (fn + (binding) + (let + ((vname (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (first binding)))) (append! names vname) (append! val-exprs (nth binding 1)) (env-bind! local vname nil))) bindings) - ;; Clojure-style (reduce - (fn (acc pair-idx) - (let ((vname (if (= (type-of (nth bindings (* pair-idx 2))) "symbol") - (symbol-name (nth bindings (* pair-idx 2))) - (nth bindings (* pair-idx 2)))) - (val-expr (nth bindings (inc (* pair-idx 2))))) + (fn + (acc pair-idx) + (let + ((vname (if (= (type-of (nth bindings (* pair-idx 2))) "symbol") (symbol-name (nth bindings (* pair-idx 2))) (nth bindings (* pair-idx 2)))) + (val-expr (nth bindings (inc (* pair-idx 2))))) (append! names vname) (append! val-exprs val-expr) (env-bind! local vname nil))) nil (range 0 (/ (len bindings) 2)))) - ;; Second pass: evaluate values (they can see each other's names) - (let ((values (map (fn (e) (trampoline (eval-expr e local))) val-exprs))) - ;; Bind final values + (let + ((values (map (fn (e) (trampoline (eval-expr e local))) val-exprs))) (for-each (fn (pair) (env-bind! local (first pair) (nth pair 1))) (zip names values)) - ;; Patch lambda closures so they see the final bindings (for-each - (fn (val) - (when (lambda? val) + (fn + (val) + (when + (lambda? val) (for-each - (fn (n) (env-bind! (lambda-closure val) n (env-get local n))) + (fn + (n) + (env-bind! (lambda-closure val) n (env-get local n))) names))) values)) - ;; Evaluate body (for-each (fn (e) (trampoline (eval-expr e local))) (slice body 0 (dec (len body)))) (make-thunk (last body) local)))) - -;; -------------------------------------------------------------------------- -;; 6d. dynamic-wind — entry/exit guards -;; -------------------------------------------------------------------------- -;; -;; (dynamic-wind before-thunk body-thunk after-thunk) -;; -;; All three are zero-argument functions (thunks): -;; 1. Call before-thunk -;; 2. Call body-thunk, capture result -;; 3. Call after-thunk (always, even on error) -;; 4. Return body result -;; -;; The wind stack is maintained so that when continuations jump across -;; dynamic-wind boundaries, the correct before/after thunks fire. -;; Without active continuations, this is equivalent to try/finally. -;; -;; Platform requirements: -;; (push-wind! before after) — push wind record onto stack -;; (pop-wind!) — pop wind record from stack -;; (call-thunk f env) — call a zero-arg function -;; -------------------------------------------------------------------------- - -;; step-sf-letrec: sf-letrec evaluates bindings + intermediate body, -;; returns a thunk for the last body expression. Unwrap into CEK state -;; so the last expression is properly evaluated by the CEK machine. -(define step-sf-letrec - (fn (args env kont) - (let ((thk (sf-letrec args env))) +(define + step-sf-letrec + (fn + (args env kont) + (let + ((thk (sf-letrec args env))) (make-cek-state (thunk-expr thk) (thunk-env thk) kont)))) -(define sf-dynamic-wind - (fn ((args :as list) (env :as dict)) - (let ((before (trampoline (eval-expr (first args) env))) - (body (trampoline (eval-expr (nth args 1) env))) - (after (trampoline (eval-expr (nth args 2) env)))) - ;; Delegate to platform — needs try/finally for error safety +(define + sf-dynamic-wind + (fn + ((args :as list) (env :as dict)) + (let + ((before (trampoline (eval-expr (first args) env))) + (body (trampoline (eval-expr (nth args 1) env))) + (after (trampoline (eval-expr (nth args 2) env)))) (dynamic-wind-call before body after env)))) - -;; -------------------------------------------------------------------------- -;; 6a2. scope — unified render-time dynamic scope primitive -;; -------------------------------------------------------------------------- -;; -;; (scope name body...) or (scope name :value v body...) -;; Push a named scope with optional value and empty accumulator, -;; evaluate body, pop scope. Returns last body result. -;; -;; `provide` is sugar: (provide name value body...) = (scope name :value value body...) - -(define sf-scope - (fn ((args :as list) (env :as dict)) - (let ((name (trampoline (eval-expr (first args) env))) - (rest (slice args 1)) - (val nil) - (body-exprs nil)) - ;; Check for :value keyword - (if (and (>= (len rest) 2) (= (type-of (first rest)) "keyword") (= (keyword-name (first rest)) "value")) - (do (set! val (trampoline (eval-expr (nth rest 1) env))) - (set! body-exprs (slice rest 2))) +(define + sf-scope + (fn + ((args :as list) (env :as dict)) + (let + ((name (trampoline (eval-expr (first args) env))) + (rest (slice args 1)) + (val nil) + (body-exprs nil)) + (if + (and + (>= (len rest) 2) + (= (type-of (first rest)) "keyword") + (= (keyword-name (first rest)) "value")) + (do + (set! val (trampoline (eval-expr (nth rest 1) env))) + (set! body-exprs (slice rest 2))) (set! body-exprs rest)) (scope-push! name val) - (let ((result nil)) - (for-each (fn (e) (set! result (trampoline (eval-expr e env)))) body-exprs) + (let + ((result nil)) + (for-each + (fn (e) (set! result (trampoline (eval-expr e env)))) + body-exprs) (scope-pop! name) result)))) - -;; provide — sugar for scope with a value -;; (provide name value body...) → (scope name :value value body...) - -(define sf-provide - (fn ((args :as list) (env :as dict)) - (let ((name (trampoline (eval-expr (first args) env))) - (val (trampoline (eval-expr (nth args 1) env))) - (body-exprs (slice args 2)) - (result nil)) +(define + sf-provide + (fn + ((args :as list) (env :as dict)) + (let + ((name (trampoline (eval-expr (first args) env))) + (val (trampoline (eval-expr (nth args 1) env))) + (body-exprs (slice args 2)) + (result nil)) (scope-push! name val) - (for-each (fn (e) (set! result (trampoline (eval-expr e env)))) body-exprs) + (for-each + (fn (e) (set! result (trampoline (eval-expr e env)))) + body-exprs) (scope-pop! name) result))) - -;; -------------------------------------------------------------------------- -;; 6b. Macro expansion -;; -------------------------------------------------------------------------- - -(define expand-macro - (fn ((mac :as macro) (raw-args :as list) (env :as dict)) - (let ((local (env-merge (macro-closure mac) env))) - ;; Bind positional params (unevaluated) +(define + expand-macro + (fn + ((mac :as macro) (raw-args :as list) (env :as dict)) + (let + ((local (env-merge (macro-closure mac) env))) (for-each - (fn (pair) - (env-bind! local (first pair) - (if (< (nth pair 1) (len raw-args)) + (fn + (pair) + (env-bind! + local + (first pair) + (if + (< (nth pair 1) (len raw-args)) (nth raw-args (nth pair 1)) nil))) (map-indexed (fn (i p) (list p i)) (macro-params mac))) - ;; Bind &rest param - (when (macro-rest-param mac) - (env-bind! local (macro-rest-param mac) + (when + (macro-rest-param mac) + (env-bind! + local + (macro-rest-param mac) (slice raw-args (len (macro-params mac))))) - ;; Evaluate body → new AST (trampoline (eval-expr (macro-body mac) local))))) +(define + cek-run + (fn + (state) + (if (cek-terminal? state) (cek-value state) (cek-run (cek-step state))))) - -;; -------------------------------------------------------------------------- -;; 8. Primitives — pure functions available in all targets -;; -------------------------------------------------------------------------- -;; These are the ~80 built-in functions. Each target implements them -;; natively but they MUST have identical semantics. This section serves -;; as the specification — bootstrap compilers use it for reference. -;; -;; Primitives are NOT defined here as SX lambdas (that would be circular). -;; Instead, this is a declarative registry that bootstrap compilers read. -;; -------------------------------------------------------------------------- - -;; See primitives.sx for the full specification. - - -;; -------------------------------------------------------------------------- -;; 9. Platform interface — must be provided by each target -;; -------------------------------------------------------------------------- -;; -;; Type inspection: -;; (type-of x) → "number" | "string" | "boolean" | "nil" -;; | "symbol" | "keyword" | "list" | "dict" -;; | "lambda" | "component" | "macro" | "thunk" -;; | "spread" -;; (symbol-name sym) → string -;; (keyword-name kw) → string -;; -;; Constructors: -;; (make-lambda params body env) → Lambda -;; (make-component name params has-children body env affinity) → Component -;; (make-macro params rest-param body env name) → Macro -;; (make-thunk expr env) → Thunk -;; -;; Accessors: -;; (lambda-params f) → list of strings -;; (lambda-body f) → expr -;; (lambda-closure f) → env -;; (lambda-name f) → string or nil -;; (set-lambda-name! f n) → void -;; (component-params c) → list of strings -;; (component-body c) → expr -;; (component-closure c) → env -;; (component-has-children? c) → boolean -;; (component-affinity c) → "auto" | "client" | "server" -;; -;; (make-island name params has-children body env) → Island -;; (island? x) → boolean -;; ;; Islands reuse component accessors: component-params, component-body, etc. -;; -;; (make-spread attrs) → Spread (attrs dict injected onto parent element) -;; (spread? x) → boolean -;; (spread-attrs s) → dict -;; -;; (macro-params m) → list of strings -;; (macro-rest-param m) → string or nil -;; (macro-body m) → expr -;; (macro-closure m) → env -;; (thunk? x) → boolean -;; (thunk-expr t) → expr -;; (thunk-env t) → env -;; -;; Predicates: -;; (callable? x) → boolean (native function or lambda) -;; (lambda? x) → boolean -;; (component? x) → boolean -;; (island? x) → boolean -;; (macro? x) → boolean -;; (primitive? name) → boolean (is name a registered primitive?) -;; (get-primitive name) → function -;; -;; Environment: -;; (env-has? env name) → boolean -;; (env-get env name) → value -;; (env-bind! env name val) → void (create binding on THIS env, no chain walk) -;; (env-set! env name val) → void (mutate existing binding, walks scope chain) -;; (env-extend env) → new env inheriting from env -;; (env-merge base overlay) → new env with overlay on top -;; -;; Mutation helpers (for parse-keyword-args): -;; (dict-set! d key val) → void -;; (dict-get d key) → value or nil -;; (append! lst val) → void (mutating append) -;; -;; Error: -;; (error msg) → raise/throw with message -;; (inspect x) → string representation for debugging -;; -;; Utility: -;; (strip-prefix s prefix) → string with prefix removed (or s unchanged) -;; (apply f args) → call f with args list -;; (zip lists...) → list of tuples -;; -;; -;; Dynamic wind (for dynamic-wind): -;; (push-wind! before after) → void (push wind record onto stack) -;; (pop-wind!) → void (pop wind record from stack) -;; (call-thunk f env) → value (call a zero-arg function) -;; -;; Extension hooks (set by web adapters, type system, etc.): -;; *custom-special-forms* — dict of name → handler fn -;; register-special-form! — (name handler) → registers custom form -;; *render-check* — nil or (expr env) → boolean -;; *render-fn* — nil or (expr env) → value -;; -------------------------------------------------------------------------- - - -;; ************************************************************************** -;; Part 3: CEK Machine — the sole evaluator -;; ************************************************************************** - -;; -------------------------------------------------------------------------- -;; 1. Run loop — drive the CEK machine to completion -;; -------------------------------------------------------------------------- - -(define cek-run - (fn (state) - ;; Drive the CEK machine until terminal state. - ;; Returns the final value. - (if (cek-terminal? state) - (cek-value state) - (cek-run (cek-step state))))) - - -;; -------------------------------------------------------------------------- -;; 2. Step function — single CEK step -;; -------------------------------------------------------------------------- - -(define cek-step - (fn (state) - (if (= (cek-phase state) "eval") +(define + cek-step + (fn + (state) + (if + (= (cek-phase state) "eval") (step-eval state) (step-continue state)))) - -;; -------------------------------------------------------------------------- -;; 3. step-eval — Control is an expression, dispatch on type -;; -------------------------------------------------------------------------- - -(define step-eval - (fn (state) - (let ((expr (cek-control state)) - (env (cek-env state)) - (kont (cek-kont state))) - (case (type-of expr) - - ;; --- Literals: immediate value --- - "number" (make-cek-value expr env kont) - "string" (make-cek-value expr env kont) - "boolean" (make-cek-value expr env kont) - "nil" (make-cek-value nil env kont) - - ;; --- Symbol lookup --- +(define + step-eval + (fn + (state) + (let + ((expr (cek-control state)) + (env (cek-env state)) + (kont (cek-kont state))) + (case + (type-of expr) + "number" + (make-cek-value expr env kont) + "string" + (make-cek-value expr env kont) + "boolean" + (make-cek-value expr env kont) + "nil" + (make-cek-value nil env kont) "symbol" - (let ((name (symbol-name expr))) - (let ((val (cond - (env-has? env name) (env-get env name) - (primitive? name) (get-primitive name) - (= name "true") true - (= name "false") false - (= name "nil") nil - :else (error (str "Undefined symbol: " name))))) - ;; Warn when a ~component symbol resolves to nil (likely missing) - (when (and (nil? val) (starts-with? name "~")) - (debug-log "Component not found:" name)) - (make-cek-value val env kont))) - - ;; --- Keyword → string --- - "keyword" (make-cek-value (keyword-name expr) env kont) - - ;; --- Dict literal: evaluate values --- + (let + ((name (symbol-name expr))) + (let + ((val (cond (env-has? env name) (env-get env name) (primitive? name) (get-primitive name) (= name "true") true (= name "false") false (= name "nil") nil :else (error (str "Undefined symbol: " name))))) + (when + (and (nil? val) (starts-with? name "~")) + (debug-log "Component not found:" name)) + (make-cek-value val env kont))) + "keyword" + (make-cek-value (keyword-name expr) env kont) "dict" - (let ((ks (keys expr))) - (if (empty? ks) - (make-cek-value (dict) env kont) - ;; Build entry pairs from dict, evaluate first value - (let ((first-key (first ks)) - (remaining-entries (list))) - (for-each (fn (k) (append! remaining-entries (list k (get expr k)))) - (rest ks)) - (make-cek-state - (get expr first-key) - env - (kont-push - (make-dict-frame - remaining-entries - (list (list first-key)) ;; results: list of (key) waiting for val - env) - kont))))) - - ;; --- List = call or special form --- + (let + ((ks (keys expr))) + (if + (empty? ks) + (make-cek-value (dict) env kont) + (let + ((first-key (first ks)) (remaining-entries (list))) + (for-each + (fn (k) (append! remaining-entries (list k (get expr k)))) + (rest ks)) + (make-cek-state + (get expr first-key) + env + (kont-push + (make-dict-frame + remaining-entries + (list (list first-key)) + env) + kont))))) "list" - (if (empty? expr) - (make-cek-value (list) env kont) - (step-eval-list expr env kont)) - - ;; --- Anything else passes through --- + (if + (empty? expr) + (make-cek-value (list) env kont) + (step-eval-list expr env kont)) :else (make-cek-value expr env kont))))) - -;; -------------------------------------------------------------------------- -;; 4. step-eval-list — Dispatch on list head -;; -------------------------------------------------------------------------- - -(define step-eval-list - (fn (expr env kont) - (let ((head (first expr)) - (args (rest expr))) - - ;; If head isn't symbol/lambda/list → treat as data list - (if (not (or (= (type-of head) "symbol") - (= (type-of head) "lambda") - (= (type-of head) "list"))) - ;; Evaluate as data list — evaluate each element - (if (empty? expr) +(define + step-eval-list + (fn + (expr env kont) + (let + ((head (first expr)) (args (rest expr))) + (if + (not + (or + (= (type-of head) "symbol") + (= (type-of head) "lambda") + (= (type-of head) "list"))) + (if + (empty? expr) (make-cek-value (list) env kont) (make-cek-state - (first expr) env + (first expr) + env (kont-push (make-map-frame nil (rest expr) (list) env) kont))) - - ;; Head is symbol — check special forms - (if (= (type-of head) "symbol") - (let ((name (symbol-name head))) + (if + (= (type-of head) "symbol") + (let + ((name (symbol-name head))) (cond - ;; --- Special forms → push appropriate frame --- - (= name "if") (step-sf-if args env kont) - (= name "when") (step-sf-when args env kont) - (= name "cond") (step-sf-cond args env kont) - (= name "case") (step-sf-case args env kont) - (= name "and") (step-sf-and args env kont) - (= name "or") (step-sf-or args env kont) - (= name "let") (step-sf-let args env kont) - (= name "let*") (step-sf-let args env kont) - (= name "lambda") (step-sf-lambda args env kont) - (= name "fn") (step-sf-lambda args env kont) - (= name "define") (step-sf-define args env kont) - (= name "defcomp") (make-cek-value (sf-defcomp args env) env kont) - (= name "defisland") (make-cek-value (sf-defisland args env) env kont) - (= name "defmacro") (make-cek-value (sf-defmacro args env) env kont) - (= name "begin") (step-sf-begin args env kont) - (= name "do") (step-sf-begin args env kont) - (= name "quote") (make-cek-value (if (empty? args) nil (first args)) env kont) - (= name "quasiquote") (make-cek-value (qq-expand (first args) env) env kont) - (= name "->") (step-sf-thread-first args env kont) - (= name "set!") (step-sf-set! args env kont) - (= name "letrec") (step-sf-letrec args env kont) - - ;; Continuations — native in CEK - (= name "reset") (step-sf-reset args env kont) - (= name "shift") (step-sf-shift args env kont) - - ;; Reactive deref-as-shift - (= name "deref") (step-sf-deref args env kont) - - ;; Scoped effects — frame-based dynamic scope - (= name "scope") (step-sf-scope args env kont) - (= name "provide") (step-sf-provide args env kont) - (= name "context") (step-sf-context args env kont) - (= name "emit!") (step-sf-emit args env kont) - (= name "emitted") (step-sf-emitted args env kont) - - ;; Dynamic wind - (= name "dynamic-wind") (make-cek-value (sf-dynamic-wind args env) env kont) - - ;; Higher-order forms - (= name "map") (step-ho-map args env kont) - (= name "map-indexed") (step-ho-map-indexed args env kont) - (= name "filter") (step-ho-filter args env kont) - (= name "reduce") (step-ho-reduce args env kont) - (= name "some") (step-ho-some args env kont) - (= name "every?") (step-ho-every args env kont) - (= name "for-each") (step-ho-for-each args env kont) - - ;; Custom special forms (registered by extensions) + (= name "if") + (step-sf-if args env kont) + (= name "when") + (step-sf-when args env kont) + (= name "cond") + (step-sf-cond args env kont) + (= name "case") + (step-sf-case args env kont) + (= name "and") + (step-sf-and args env kont) + (= name "or") + (step-sf-or args env kont) + (= name "let") + (step-sf-let args env kont) + (= name "let*") + (step-sf-let args env kont) + (= name "lambda") + (step-sf-lambda args env kont) + (= name "fn") + (step-sf-lambda args env kont) + (= name "define") + (step-sf-define args env kont) + (= name "defcomp") + (make-cek-value (sf-defcomp args env) env kont) + (= name "defisland") + (make-cek-value (sf-defisland args env) env kont) + (= name "defmacro") + (make-cek-value (sf-defmacro args env) env kont) + (= name "begin") + (step-sf-begin args env kont) + (= name "do") + (step-sf-begin args env kont) + (= name "quote") + (make-cek-value (if (empty? args) nil (first args)) env kont) + (= name "quasiquote") + (make-cek-value (qq-expand (first args) env) env kont) + (= name "->") + (step-sf-thread-first args env kont) + (= name "set!") + (step-sf-set! args env kont) + (= name "letrec") + (step-sf-letrec args env kont) + (= name "reset") + (step-sf-reset args env kont) + (= name "shift") + (step-sf-shift args env kont) + (= name "deref") + (step-sf-deref args env kont) + (= name "scope") + (step-sf-scope args env kont) + (= name "provide") + (step-sf-provide args env kont) + (= name "context") + (step-sf-context args env kont) + (= name "emit!") + (step-sf-emit args env kont) + (= name "emitted") + (step-sf-emitted args env kont) + (= name "handler-bind") + (step-sf-handler-bind args env kont) + (= name "restart-case") + (step-sf-restart-case args env kont) + (= name "signal") + (step-sf-signal args env kont) + (= name "invoke-restart") + (step-sf-invoke-restart args env kont) + (= name "match") + (step-sf-match args env kont) + (= name "dynamic-wind") + (make-cek-value (sf-dynamic-wind args env) env kont) + (= name "map") + (step-ho-map args env kont) + (= name "map-indexed") + (step-ho-map-indexed args env kont) + (= name "filter") + (step-ho-filter args env kont) + (= name "reduce") + (step-ho-reduce args env kont) + (= name "some") + (step-ho-some args env kont) + (= name "every?") + (step-ho-every args env kont) + (= name "for-each") + (step-ho-for-each args env kont) (has-key? *custom-special-forms* name) - (make-cek-value - ((get *custom-special-forms* name) args env) - env kont) - - ;; Macro expansion + (make-cek-value + ((get *custom-special-forms* name) args env) + env + kont) (and (env-has? env name) (macro? (env-get env name))) - (let ((mac (env-get env name))) - (make-cek-state (expand-macro mac args env) env kont)) - - ;; Render dispatch (installed by web adapters) + (let + ((mac (env-get env name))) + (make-cek-state (expand-macro mac args env) env kont)) (and *render-check* (*render-check* expr env)) - (make-cek-value (*render-fn* expr env) env kont) - - ;; Fall through to function call + (make-cek-value (*render-fn* expr env) env kont) :else (step-eval-call head args env kont))) - - ;; Head is lambda or list — function call (step-eval-call head args env kont)))))) +(define + match-find-clause + (fn + (val clauses env) + (if + (empty? clauses) + nil + (let + ((clause (first clauses)) + (pattern (first clause)) + (body (nth clause 1)) + (local (env-extend env))) + (if + (match-pattern pattern val local) + (list local body) + (match-find-clause val (rest clauses) env)))))) -;; -------------------------------------------------------------------------- -;; 5. Special form step handlers -;; -------------------------------------------------------------------------- +(define + match-pattern + (fn + (pattern value env) + (cond + (= pattern (quote _)) + true + (and + (list? pattern) + (= (len pattern) 2) + (= (first pattern) (quote ?))) + (let + ((pred (trampoline (eval-expr (nth pattern 1) env)))) + (cek-call pred (list value))) + (and + (list? pattern) + (not (empty? pattern)) + (= (first pattern) (quote quote))) + (= value (nth pattern 1)) + (symbol? pattern) + (do (env-bind! env (symbol-name pattern) value) true) + (and (list? pattern) (list? value)) + (if + (not (= (len pattern) (len value))) + false + (let + ((pairs (zip pattern value))) + (every? + (fn (pair) (match-pattern (first pair) (nth pair 1) env)) + pairs))) + :else (= pattern value)))) -;; if: evaluate condition, push IfFrame -(define step-sf-if - (fn (args env kont) +(define + step-sf-match + (fn + (args env kont) + (let + ((val (trampoline (eval-expr (first args) env))) + (clauses (rest args))) + (let + ((result (match-find-clause val clauses env))) + (if + (nil? result) + (error (str "match: no clause matched " (inspect val))) + (make-cek-state (nth result 1) (first result) kont)))))) + +(define + step-sf-handler-bind + (fn + (args env kont) + (let + ((handler-specs (first args)) + (body (rest args)) + (handlers + (map + (fn + (spec) + (list + (trampoline (eval-expr (first spec) env)) + (trampoline (eval-expr (nth spec 1) env)))) + handler-specs))) + (if + (empty? body) + (make-cek-value nil env kont) + (make-cek-state + (first body) + env + (kont-push (make-handler-frame handlers (rest body) env) kont)))))) + +(define + step-sf-restart-case + (fn + (args env kont) + (let + ((body (first args)) + (restart-specs (rest args)) + (restarts + (map + (fn + (spec) + (list + (if + (symbol? (first spec)) + (symbol-name (first spec)) + (first spec)) + (nth spec 1) + (nth spec 2))) + restart-specs))) + (make-cek-state + body + env + (kont-push (make-restart-frame restarts (list) env) kont))))) + +(define + step-sf-signal + (fn + (args env kont) + (let + ((condition (trampoline (eval-expr (first args) env))) + (handler-fn (kont-find-handler kont condition))) + (if + (nil? handler-fn) + (error (str "Unhandled condition: " (inspect condition))) + (continue-with-call + handler-fn + (list condition) + env + (list condition) + (kont-push (make-signal-return-frame env kont) kont)))))) + +(define + step-sf-invoke-restart + (fn + (args env kont) + (let + ((restart-name (let ((rn (if (symbol? (first args)) (symbol-name (first args)) (trampoline (eval-expr (first args) env))))) (if (symbol? rn) (symbol-name rn) rn))) + (restart-arg + (if + (>= (len args) 2) + (trampoline (eval-expr (nth args 1) env)) + nil)) + (found (kont-find-restart kont restart-name))) + (if + (nil? found) + (error (str "No restart named: " (inspect restart-name))) + (let + ((entry (first found)) + (restart-frame (nth found 1)) + (rest-kont (nth found 2))) + (let + ((params (nth entry 1)) + (body (nth entry 2)) + (restart-env (env-extend (get restart-frame "env")))) + (when + (not (empty? params)) + (env-bind! restart-env (first params) restart-arg)) + (make-cek-state body restart-env rest-kont))))))) + +(define + step-sf-if + (fn + (args env kont) (make-cek-state - (first args) env + (first args) + env (kont-push - (make-if-frame (nth args 1) + (make-if-frame + (nth args 1) (if (> (len args) 2) (nth args 2) nil) env) kont)))) -;; when: evaluate condition, push WhenFrame -(define step-sf-when - (fn (args env kont) +(define + step-sf-when + (fn + (args env kont) (make-cek-state - (first args) env + (first args) + env (kont-push (make-when-frame (rest args) env) kont)))) -;; begin/do: evaluate first expr, push BeginFrame for rest -(define step-sf-begin - (fn (args env kont) - (if (empty? args) +(define + step-sf-begin + (fn + (args env kont) + (if + (empty? args) (make-cek-value nil env kont) - (if (= (len args) 1) + (if + (= (len args) 1) (make-cek-state (first args) env kont) (make-cek-state - (first args) env + (first args) + env (kont-push (make-begin-frame (rest args) env) kont)))))) -;; let: start evaluating bindings -(define step-sf-let - (fn (args env kont) - ;; Detect named let - (if (= (type-of (first args)) "symbol") - ;; Named let — delegate to existing handler (complex desugaring) +(define + step-sf-let + (fn + (args env kont) + (if + (= (type-of (first args)) "symbol") (make-cek-value (sf-named-let args env) env kont) - (let ((bindings (first args)) - (body (rest args)) - (local (env-extend env))) - ;; Parse first binding - (if (empty? bindings) - ;; No bindings — evaluate body + (let + ((bindings (first args)) + (body (rest args)) + (local (env-extend env))) + (if + (empty? bindings) (step-sf-begin body local kont) - ;; Start evaluating first binding value - (let ((first-binding (if (and (= (type-of (first bindings)) "list") - (= (len (first bindings)) 2)) - ;; Scheme-style: ((name val) ...) - (first bindings) - ;; Clojure-style: (name val ...) → synthesize pair - (list (first bindings) (nth bindings 1)))) - (rest-bindings (if (and (= (type-of (first bindings)) "list") - (= (len (first bindings)) 2)) - (rest bindings) - ;; Clojure-style: skip 2 elements - (let ((pairs (list))) - (reduce - (fn (acc i) - (append! pairs (list (nth bindings (* i 2)) - (nth bindings (inc (* i 2)))))) - nil - (range 1 (/ (len bindings) 2))) - pairs)))) - (let ((vname (if (= (type-of (first first-binding)) "symbol") - (symbol-name (first first-binding)) - (first first-binding)))) + (let + ((first-binding (if (and (= (type-of (first bindings)) "list") (= (len (first bindings)) 2)) (first bindings) (list (first bindings) (nth bindings 1)))) + (rest-bindings + (if + (and + (= (type-of (first bindings)) "list") + (= (len (first bindings)) 2)) + (rest bindings) + (let + ((pairs (list))) + (reduce + (fn + (acc i) + (append! + pairs + (list + (nth bindings (* i 2)) + (nth bindings (inc (* i 2)))))) + nil + (range 1 (/ (len bindings) 2))) + pairs)))) + (let + ((vname (if (= (type-of (first first-binding)) "symbol") (symbol-name (first first-binding)) (first first-binding)))) (make-cek-state - (nth first-binding 1) local + (nth first-binding 1) + local (kont-push (make-let-frame vname rest-bindings body local) kont))))))))) -;; define: evaluate value expression -(define step-sf-define - (fn (args env kont) - (let ((name-sym (first args)) - (has-effects (and (>= (len args) 4) - (= (type-of (nth args 1)) "keyword") - (= (keyword-name (nth args 1)) "effects"))) - (val-idx (if (and (>= (len args) 4) - (= (type-of (nth args 1)) "keyword") - (= (keyword-name (nth args 1)) "effects")) - 3 1)) - (effect-list (if (and (>= (len args) 4) - (= (type-of (nth args 1)) "keyword") - (= (keyword-name (nth args 1)) "effects")) - (nth args 2) nil))) +(define + step-sf-define + (fn + (args env kont) + (let + ((name-sym (first args)) + (has-effects + (and + (>= (len args) 4) + (= (type-of (nth args 1)) "keyword") + (= (keyword-name (nth args 1)) "effects"))) + (val-idx + (if + (and + (>= (len args) 4) + (= (type-of (nth args 1)) "keyword") + (= (keyword-name (nth args 1)) "effects")) + 3 + 1)) + (effect-list + (if + (and + (>= (len args) 4) + (= (type-of (nth args 1)) "keyword") + (= (keyword-name (nth args 1)) "effects")) + (nth args 2) + nil))) (make-cek-state - (nth args val-idx) env + (nth args val-idx) + env (kont-push - (make-define-frame (symbol-name name-sym) env has-effects effect-list) + (make-define-frame + (symbol-name name-sym) + env + has-effects + effect-list) kont))))) -;; set!: evaluate value -(define step-sf-set! - (fn (args env kont) +(define + step-sf-set! + (fn + (args env kont) (make-cek-state - (nth args 1) env + (nth args 1) + env (kont-push (make-set-frame (symbol-name (first args)) env) kont)))) -;; and: evaluate first, push AndFrame -(define step-sf-and - (fn (args env kont) - (if (empty? args) +(define + step-sf-and + (fn + (args env kont) + (if + (empty? args) (make-cek-value true env kont) (make-cek-state - (first args) env + (first args) + env (kont-push (make-and-frame (rest args) env) kont))))) -;; or: evaluate first, push OrFrame -(define step-sf-or - (fn (args env kont) - (if (empty? args) +(define + step-sf-or + (fn + (args env kont) + (if + (empty? args) (make-cek-value false env kont) (make-cek-state - (first args) env + (first args) + env (kont-push (make-or-frame (rest args) env) kont))))) -;; cond: evaluate first test, push CondFrame -(define step-sf-cond - (fn (args env kont) - (let ((scheme? (cond-scheme? args))) - (if scheme? - ;; Scheme-style: ((test body) ...) - (if (empty? args) +(define + step-sf-cond + (fn + (args env kont) + (let + ((scheme? (cond-scheme? args))) + (if + scheme? + (if + (empty? args) (make-cek-value nil env kont) - (let ((clause (first args)) - (test (first clause))) - ;; Check for :else / else - (if (is-else-clause? test) + (let + ((clause (first args)) (test (first clause))) + (if + (is-else-clause? test) (make-cek-state (nth clause 1) env kont) (make-cek-state - test env + test + env (kont-push (make-cond-frame args env true) kont))))) - ;; Clojure-style: test body test body ... - (if (< (len args) 2) + (if + (< (len args) 2) (make-cek-value nil env kont) - (let ((test (first args))) - (if (is-else-clause? test) + (let + ((test (first args))) + (if + (is-else-clause? test) (make-cek-state (nth args 1) env kont) (make-cek-state - test env + test + env (kont-push (make-cond-frame args env false) kont))))))))) -;; case: evaluate match value -(define step-sf-case - (fn (args env kont) +(define + step-sf-case + (fn + (args env kont) (make-cek-state - (first args) env + (first args) + env (kont-push (make-case-frame nil (rest args) env) kont)))) -;; thread-first: evaluate initial value -(define step-sf-thread-first - (fn (args env kont) +(define + step-sf-thread-first + (fn + (args env kont) (make-cek-state - (first args) env + (first args) + env (kont-push (make-thread-frame (rest args) env) kont)))) -;; lambda/fn: immediate — create lambda value -(define step-sf-lambda - (fn (args env kont) - (make-cek-value (sf-lambda args env) env kont))) +(define + step-sf-lambda + (fn (args env kont) (make-cek-value (sf-lambda args env) env kont))) -;; scope: evaluate name, then push ScopeFrame -;; scope/provide/context/emit!/emitted — CEK frame-based. -;; provide/scope push proper CEK frames onto the continuation so that -;; shift/reset can capture and restore them correctly. -;; context/emit!/emitted walk the kont to find the relevant frame. - -;; scope: push ScopeAccFrame, evaluate body expressions via continuation. -;; (scope name body...) or (scope name :value v body...) -(define step-sf-scope - (fn (args env kont) - (let ((name (trampoline (eval-expr (first args) env))) - (rest-args (slice args 1)) - (val nil) - (body nil)) - (if (and (>= (len rest-args) 2) - (= (type-of (first rest-args)) "keyword") - (= (keyword-name (first rest-args)) "value")) - (do (set! val (trampoline (eval-expr (nth rest-args 1) env))) - (set! body (slice rest-args 2))) +(define + step-sf-scope + (fn + (args env kont) + (let + ((name (trampoline (eval-expr (first args) env))) + (rest-args (slice args 1)) + (val nil) + (body nil)) + (if + (and + (>= (len rest-args) 2) + (= (type-of (first rest-args)) "keyword") + (= (keyword-name (first rest-args)) "value")) + (do + (set! val (trampoline (eval-expr (nth rest-args 1) env))) + (set! body (slice rest-args 2))) (set! body rest-args)) - (if (empty? body) + (if + (empty? body) (make-cek-value nil env kont) (make-cek-state - (first body) env + (first body) + env (kont-push (make-scope-acc-frame name val (rest body) env) kont)))))) -;; provide: push ProvideFrame, evaluate body expressions via continuation. -(define step-sf-provide - (fn (args env kont) - (let ((name (trampoline (eval-expr (first args) env))) - (val (trampoline (eval-expr (nth args 1) env))) - (body (slice args 2))) - (if (empty? body) +(define + step-sf-provide + (fn + (args env kont) + (let + ((name (trampoline (eval-expr (first args) env))) + (val (trampoline (eval-expr (nth args 1) env))) + (body (slice args 2))) + (if + (empty? body) (make-cek-value nil env kont) (make-cek-state - (first body) env + (first body) + env (kont-push (make-provide-frame name val (rest body) env) kont)))))) -;; context: walk kont for nearest ProvideFrame with matching name. -(define step-sf-context - (fn (args env kont) - (let ((name (trampoline (eval-expr (first args) env))) - (default-val (if (>= (len args) 2) - (trampoline (eval-expr (nth args 1) env)) - nil)) - (frame (kont-find-provide kont name))) - (make-cek-value (if (nil? frame) default-val (get frame "value")) env kont)))) +(define + step-sf-context + (fn + (args env kont) + (let + ((name (trampoline (eval-expr (first args) env))) + (default-val + (if + (>= (len args) 2) + (trampoline (eval-expr (nth args 1) env)) + nil)) + (frame (kont-find-provide kont name))) + (make-cek-value + (if (nil? frame) default-val (get frame "value")) + env + kont)))) -;; emit!: walk kont for nearest ScopeAccFrame, append to its emitted list. -(define step-sf-emit - (fn (args env kont) - (let ((name (trampoline (eval-expr (first args) env))) - (val (trampoline (eval-expr (nth args 1) env))) - (frame (kont-find-scope-acc kont name))) - (when frame - (dict-set! frame "emitted" (append (get frame "emitted") (list val)))) +(define + step-sf-emit + (fn + (args env kont) + (let + ((name (trampoline (eval-expr (first args) env))) + (val (trampoline (eval-expr (nth args 1) env))) + (frame (kont-find-scope-acc kont name))) + (when + frame + (dict-set! + frame + "emitted" + (append (get frame "emitted") (list val)))) (make-cek-value nil env kont)))) -;; emitted: walk kont for nearest ScopeAccFrame, return its emitted list. -(define step-sf-emitted - (fn (args env kont) - (let ((name (trampoline (eval-expr (first args) env))) - (frame (kont-find-scope-acc kont name))) - (make-cek-value (if (nil? frame) (list) (get frame "emitted")) env kont)))) +(define + step-sf-emitted + (fn + (args env kont) + (let + ((name (trampoline (eval-expr (first args) env))) + (frame (kont-find-scope-acc kont name))) + (make-cek-value + (if (nil? frame) (list) (get frame "emitted")) + env + kont)))) -;; reset: push ResetFrame, evaluate body -(define step-sf-reset - (fn (args env kont) +(define + step-sf-reset + (fn + (args env kont) (make-cek-state - (first args) env + (first args) + env (kont-push (make-reset-frame env) kont)))) -;; shift: capture frames to nearest reset -(define step-sf-shift - (fn (args env kont) - (let ((k-name (symbol-name (first args))) - (body (nth args 1)) - (captured-result (kont-capture-to-reset kont)) - (captured (first captured-result)) - (rest-kont (nth captured-result 1))) - ;; Store captured frames as a dict on the continuation value. - ;; When the continuation is invoked, continue-with-call detects - ;; the cek-frames key and restores them. - (let ((k (make-cek-continuation captured rest-kont))) - ;; Evaluate shift body with k bound, continuation goes to rest-kont - (let ((shift-env (env-extend env))) +(define + step-sf-shift + (fn + (args env kont) + (let + ((k-name (symbol-name (first args))) + (body (nth args 1)) + (captured-result (kont-capture-to-reset kont)) + (captured (first captured-result)) + (rest-kont (nth captured-result 1))) + (let + ((k (make-cek-continuation captured rest-kont))) + (let + ((shift-env (env-extend env))) (env-bind! shift-env k-name k) (make-cek-state body shift-env rest-kont)))))) - -;; deref: evaluate argument, push DerefFrame -(define step-sf-deref - (fn (args env kont) +(define + step-sf-deref + (fn + (args env kont) (make-cek-state - (first args) env + (first args) + env (kont-push (make-deref-frame env) kont)))) -;; cek-call — call a function via CEK (replaces invoke) -;; cek-call — unified function dispatch -;; Both lambdas and native callables go through continue-with-call -;; so they interact identically with the continuation stack. -;; This is critical: replacing a native callable with an SX lambda -;; (e.g. stdlib.sx) must not change shift/reset behavior. -(define cek-call - (fn (f args) - (let ((a (if (nil? args) (list) args))) +(define + cek-call + (fn + (f args) + (let + ((a (if (nil? args) (list) args))) (cond - (nil? f) nil + (nil? f) + nil (or (lambda? f) (callable? f)) - (cek-run (continue-with-call f a (make-env) a (list))) + (cek-run (continue-with-call f a (make-env) a (list))) :else nil)))) -;; reactive-shift-deref: the heart of deref-as-shift -;; When deref encounters a signal inside a reactive-reset boundary, -;; capture the continuation up to the reactive-reset as the subscriber. -(define reactive-shift-deref - (fn (sig env kont) - (let ((scan-result (kont-capture-to-reactive-reset kont)) - (captured-frames (first scan-result)) - (reset-frame (nth scan-result 1)) - (remaining-kont (nth scan-result 2)) - (update-fn (get reset-frame "update-fn"))) - ;; Sub-scope for nested subscriber cleanup on re-invocation - (let ((sub-disposers (list))) - (let ((subscriber - (fn () - ;; Dispose previous nested subscribers - (for-each (fn (d) (cek-call d nil)) sub-disposers) - (set! sub-disposers (list)) - ;; Re-invoke: push fresh ReactiveResetFrame (first-render=false) - (let ((new-reset (make-reactive-reset-frame env update-fn false)) - (new-kont (concat captured-frames - (list new-reset) - remaining-kont))) - (with-island-scope - (fn (d) (append! sub-disposers d)) - (fn () - (cek-run - (make-cek-value (signal-value sig) env new-kont)))))))) - ;; Register subscriber +(define + reactive-shift-deref + (fn + (sig env kont) + (let + ((scan-result (kont-capture-to-reactive-reset kont)) + (captured-frames (first scan-result)) + (reset-frame (nth scan-result 1)) + (remaining-kont (nth scan-result 2)) + (update-fn (get reset-frame "update-fn"))) + (let + ((sub-disposers (list))) + (let + ((subscriber (fn () (for-each (fn (d) (cek-call d nil)) sub-disposers) (set! sub-disposers (list)) (let ((new-reset (make-reactive-reset-frame env update-fn false)) (new-kont (concat captured-frames (list new-reset) remaining-kont))) (with-island-scope (fn (d) (append! sub-disposers d)) (fn () (cek-run (make-cek-value (signal-value sig) env new-kont)))))))) (signal-add-sub! sig subscriber) - ;; Register cleanup with island scope (register-in-scope - (fn () + (fn + () (signal-remove-sub! sig subscriber) (for-each (fn (d) (cek-call d nil)) sub-disposers))) - ;; Initial render: value flows through captured frames + reset (first-render=true) - ;; so the full expression completes normally - (let ((initial-kont (concat captured-frames - (list reset-frame) - remaining-kont))) + (let + ((initial-kont (concat captured-frames (list reset-frame) remaining-kont))) (make-cek-value (signal-value sig) env initial-kont))))))) - -;; -------------------------------------------------------------------------- -;; 6. Function call step handler -;; -------------------------------------------------------------------------- - -(define step-eval-call - (fn (head args env kont) - ;; First evaluate the head, then evaluate args left-to-right - ;; Preserve head name for strict mode type checking - (let ((hname (if (= (type-of head) "symbol") (symbol-name head) nil))) +(define + step-eval-call + (fn + (head args env kont) + (let + ((hname (if (= (type-of head) "symbol") (symbol-name head) nil))) (make-cek-state - head env - (kont-push - (make-arg-frame nil (list) args env args hname) - kont))))) + head + env + (kont-push (make-arg-frame nil (list) args env args hname) kont))))) +(define + ho-form-name? + (fn + (name) + (or + (= name "map") + (= name "map-indexed") + (= name "filter") + (= name "reduce") + (= name "some") + (= name "every?") + (= name "for-each")))) -;; -------------------------------------------------------------------------- -;; 7. Higher-order form step handlers -;; -------------------------------------------------------------------------- +(define ho-fn? (fn (v) (or (callable? v) (lambda? v)))) -;; CEK-native higher-order forms — each callback invocation goes through -;; continue-with-call so deref-as-shift works inside callbacks. -;; Function and collection args are evaluated via tree-walk (simple exprs), -;; then the loop is driven by CEK frames. - -;; HO step handlers — push HoSetupFrame to evaluate args via CEK -;; (no nested eval-expr calls). When all args are evaluated, the -;; HoSetupFrame dispatch in step-continue sets up the iteration frame. - -;; ho-form-name? — is this symbol name a higher-order special form? -(define ho-form-name? - (fn (name) - (or (= name "map") (= name "map-indexed") (= name "filter") - (= name "reduce") (= name "some") (= name "every?") - (= name "for-each")))) - -;; ho-fn? — is this value usable as a HO callback? -(define ho-fn? - (fn (v) (or (callable? v) (lambda? v)))) - -;; ho-swap-args: normalise data-first arg order -;; 2-arg forms: (coll fn) → (fn coll) -;; 3-arg reduce: (coll fn init) → (fn init coll) -(define ho-swap-args - (fn (ho-type evaled) - (if (= ho-type "reduce") - (let ((a (first evaled)) - (b (nth evaled 1))) - (if (and (not (ho-fn? a)) (ho-fn? b)) +(define + ho-swap-args + (fn + (ho-type evaled) + (if + (= ho-type "reduce") + (let + ((a (first evaled)) (b (nth evaled 1))) + (if + (and (not (ho-fn? a)) (ho-fn? b)) (list b (nth evaled 2) a) evaled)) - (let ((a (first evaled)) - (b (nth evaled 1))) - (if (and (not (ho-fn? a)) (ho-fn? b)) - (list b a) - evaled))))) + (let + ((a (first evaled)) (b (nth evaled 1))) + (if (and (not (ho-fn? a)) (ho-fn? b)) (list b a) evaled))))) -;; ho-setup-dispatch: all HO args evaluated, set up iteration -(define ho-setup-dispatch - (fn (ho-type evaled env kont) - (let ((ordered (ho-swap-args ho-type evaled))) - (let ((f (first ordered))) - (cond - (= ho-type "map") - (let ((coll (nth ordered 1))) - (if (empty? coll) +(define + ho-setup-dispatch + (fn + (ho-type evaled env kont) + (let + ((ordered (ho-swap-args ho-type evaled))) + (let + ((f (first ordered))) + (cond + (= 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) + (continue-with-call + f + (list (first coll)) + env + (list) (kont-push (make-map-frame f (rest coll) (list) env) kont)))) - - (= ho-type "map-indexed") - (let ((coll (nth ordered 1))) - (if (empty? coll) + (= ho-type "map-indexed") + (let + ((coll (nth ordered 1))) + (if + (empty? coll) (make-cek-value (list) env kont) - (continue-with-call f (list 0 (first coll)) env (list) - (kont-push (make-map-indexed-frame f (rest coll) (list) env) kont)))) - - (= ho-type "filter") - (let ((coll (nth ordered 1))) - (if (empty? coll) + (continue-with-call + f + (list 0 (first coll)) + env + (list) + (kont-push + (make-map-indexed-frame f (rest coll) (list) env) + kont)))) + (= ho-type "filter") + (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-filter-frame f (rest coll) (list) (first coll) env) kont)))) - - (= ho-type "reduce") - (let ((init (nth ordered 1)) - (coll (nth ordered 2))) - (if (empty? coll) + (continue-with-call + f + (list (first coll)) + env + (list) + (kont-push + (make-filter-frame f (rest coll) (list) (first coll) env) + kont)))) + (= ho-type "reduce") + (let + ((init (nth ordered 1)) (coll (nth ordered 2))) + (if + (empty? coll) (make-cek-value init env kont) - (continue-with-call f (list init (first coll)) env (list) + (continue-with-call + f + (list init (first coll)) + env + (list) (kont-push (make-reduce-frame f (rest coll) env) kont)))) - - (= ho-type "some") - (let ((coll (nth ordered 1))) - (if (empty? coll) + (= ho-type "some") + (let + ((coll (nth ordered 1))) + (if + (empty? coll) (make-cek-value false env kont) - (continue-with-call f (list (first coll)) env (list) + (continue-with-call + f + (list (first coll)) + env + (list) (kont-push (make-some-frame f (rest coll) env) kont)))) - - (= ho-type "every") - (let ((coll (nth ordered 1))) - (if (empty? coll) + (= ho-type "every") + (let + ((coll (nth ordered 1))) + (if + (empty? coll) (make-cek-value true env kont) - (continue-with-call f (list (first coll)) env (list) + (continue-with-call + f + (list (first coll)) + env + (list) (kont-push (make-every-frame f (rest coll) env) kont)))) - - (= ho-type "for-each") - (let ((coll (nth ordered 1))) - (if (empty? coll) + (= ho-type "for-each") + (let + ((coll (nth ordered 1))) + (if + (empty? coll) (make-cek-value nil env kont) - (continue-with-call f (list (first coll)) env (list) + (continue-with-call + f + (list (first coll)) + env + (list) (kont-push (make-for-each-frame f (rest coll) env) kont)))) + :else (error (str "Unknown HO type: " ho-type))))))) - :else (error (str "Unknown HO type: " ho-type))))))) - -(define step-ho-map - (fn (args env kont) - (make-cek-state (first args) env +(define + step-ho-map + (fn + (args env kont) + (make-cek-state + (first args) + env (kont-push (make-ho-setup-frame "map" (rest args) (list) env) kont)))) -(define step-ho-map-indexed - (fn (args env kont) - (make-cek-state (first args) env - (kont-push (make-ho-setup-frame "map-indexed" (rest args) (list) env) kont)))) +(define + step-ho-map-indexed + (fn + (args env kont) + (make-cek-state + (first args) + env + (kont-push + (make-ho-setup-frame "map-indexed" (rest args) (list) env) + kont)))) -(define step-ho-filter - (fn (args env kont) - (make-cek-state (first args) env +(define + step-ho-filter + (fn + (args env kont) + (make-cek-state + (first args) + env (kont-push (make-ho-setup-frame "filter" (rest args) (list) env) kont)))) -(define step-ho-reduce - (fn (args env kont) - (make-cek-state (first args) env +(define + step-ho-reduce + (fn + (args env kont) + (make-cek-state + (first args) + env (kont-push (make-ho-setup-frame "reduce" (rest args) (list) env) kont)))) -(define step-ho-some - (fn (args env kont) - (make-cek-state (first args) env +(define + step-ho-some + (fn + (args env kont) + (make-cek-state + (first args) + env (kont-push (make-ho-setup-frame "some" (rest args) (list) env) kont)))) -(define step-ho-every - (fn (args env kont) - (make-cek-state (first args) env +(define + step-ho-every + (fn + (args env kont) + (make-cek-state + (first args) + env (kont-push (make-ho-setup-frame "every" (rest args) (list) env) kont)))) -(define step-ho-for-each - (fn (args env kont) - (make-cek-state (first args) env - (kont-push (make-ho-setup-frame "for-each" (rest args) (list) env) kont)))) +(define + step-ho-for-each + (fn + (args env kont) + (make-cek-state + (first args) + env + (kont-push + (make-ho-setup-frame "for-each" (rest args) (list) env) + kont)))) - -;; -------------------------------------------------------------------------- -;; 8. step-continue — Value produced, dispatch on top frame -;; -------------------------------------------------------------------------- - -(define step-continue - (fn (state) - (let ((value (cek-value state)) - (env (cek-env state)) - (kont (cek-kont state))) - (if (kont-empty? kont) - state ;; Terminal — return as-is - (let ((frame (kont-top kont)) - (rest-k (kont-pop kont)) - (ft (frame-type frame))) +(define + step-continue + (fn + (state) + (let + ((value (cek-value state)) + (env (cek-env state)) + (kont (cek-kont state))) + (if + (kont-empty? kont) + state + (let + ((frame (kont-top kont)) + (rest-k (kont-pop kont)) + (ft (frame-type frame))) (cond - - ;; --- IfFrame: condition evaluated --- (= ft "if") - (if (and value (not (nil? value))) - (make-cek-state (get frame "then") (get frame "env") rest-k) - (if (nil? (get frame "else")) - (make-cek-value nil env rest-k) - (make-cek-state (get frame "else") (get frame "env") rest-k))) - - ;; --- WhenFrame: condition evaluated --- + (if + (and value (not (nil? value))) + (make-cek-state (get frame "then") (get frame "env") rest-k) + (if + (nil? (get frame "else")) + (make-cek-value nil env rest-k) + (make-cek-state (get frame "else") (get frame "env") rest-k))) (= ft "when") - (if (and value (not (nil? value))) - (let ((body (get frame "body")) - (fenv (get frame "env"))) - (if (empty? body) - (make-cek-value nil fenv rest-k) - (if (= (len body) 1) - (make-cek-state (first body) fenv rest-k) - (make-cek-state - (first body) fenv - (kont-push (make-begin-frame (rest body) fenv) rest-k))))) - (make-cek-value nil env rest-k)) - - ;; --- BeginFrame: expression evaluated, continue with next --- - (= ft "begin") - (let ((remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if (empty? remaining) - (make-cek-value value fenv rest-k) - (if (= (len remaining) 1) - (make-cek-state (first remaining) fenv rest-k) - (make-cek-state - (first remaining) fenv - (kont-push (make-begin-frame (rest remaining) fenv) rest-k))))) - - ;; --- LetFrame: binding value evaluated --- - (= ft "let") - (let ((name (get frame "name")) - (remaining (get frame "remaining")) - (body (get frame "body")) - (local (get frame "env"))) - ;; Bind the value - (env-bind! local name value) - ;; More bindings? - (if (empty? remaining) - ;; All bindings done — evaluate body - (step-sf-begin body local rest-k) - ;; Next binding - (let ((next-binding (first remaining)) - (vname (if (= (type-of (first next-binding)) "symbol") - (symbol-name (first next-binding)) - (first next-binding)))) - (make-cek-state - (nth next-binding 1) local - (kont-push - (make-let-frame vname (rest remaining) body local) - rest-k))))) - - ;; --- DefineFrame: value evaluated --- - (= ft "define") - (let ((name (get frame "name")) - (fenv (get frame "env")) - (has-effects (get frame "has-effects")) - (effect-list (get frame "effect-list"))) - (when (and (lambda? value) (nil? (lambda-name value))) - (set-lambda-name! value name)) - (env-bind! fenv name value) - ;; Effect annotation - (when has-effects - (let ((effect-names (if (= (type-of effect-list) "list") - (map (fn (e) (if (= (type-of e) "symbol") - (symbol-name e) (str e))) - effect-list) - (list (str effect-list)))) - (effect-anns (if (env-has? fenv "*effect-annotations*") - (env-get fenv "*effect-annotations*") - (dict)))) - (dict-set! effect-anns name effect-names) - (env-bind! fenv "*effect-annotations*" effect-anns))) - (make-cek-value value fenv rest-k)) - - ;; --- SetFrame: value evaluated --- - (= ft "set") - (let ((name (get frame "name")) - (fenv (get frame "env"))) - (env-set! fenv name value) - (make-cek-value value env rest-k)) - - ;; --- AndFrame: value evaluated --- - (= ft "and") - (if (not value) - (make-cek-value value env rest-k) - (let ((remaining (get frame "remaining"))) - (if (empty? remaining) - (make-cek-value value env rest-k) - (make-cek-state - (first remaining) (get frame "env") - (if (= (len remaining) 1) - rest-k - (kont-push (make-and-frame (rest remaining) (get frame "env")) rest-k)))))) - - ;; --- OrFrame: value evaluated --- - (= ft "or") - (if value - (make-cek-value value env rest-k) - (let ((remaining (get frame "remaining"))) - (if (empty? remaining) - (make-cek-value false env rest-k) - (make-cek-state - (first remaining) (get frame "env") - (if (= (len remaining) 1) - rest-k - (kont-push (make-or-frame (rest remaining) (get frame "env")) rest-k)))))) - - ;; --- CondFrame: test evaluated --- - (= ft "cond") - (let ((remaining (get frame "remaining")) - (fenv (get frame "env")) - (scheme? (get frame "scheme"))) - (if scheme? - ;; Scheme-style: test truthy → evaluate body - (if value - (make-cek-state (nth (first remaining) 1) fenv rest-k) - ;; Next clause - (let ((next-clauses (rest remaining))) - (if (empty? next-clauses) - (make-cek-value nil fenv rest-k) - (let ((next-clause (first next-clauses)) - (next-test (first next-clause))) - (if (is-else-clause? next-test) - (make-cek-state (nth next-clause 1) fenv rest-k) - (make-cek-state - next-test fenv - (kont-push (make-cond-frame next-clauses fenv true) rest-k))))))) - ;; Clojure-style - (if value - (make-cek-state (nth remaining 1) fenv rest-k) - (let ((next (slice remaining 2))) - (if (< (len next) 2) - (make-cek-value nil fenv rest-k) - (let ((next-test (first next))) - (if (is-else-clause? next-test) - (make-cek-state (nth next 1) fenv rest-k) - (make-cek-state - next-test fenv - (kont-push (make-cond-frame next fenv false) rest-k))))))))) - - ;; --- CaseFrame --- - (= ft "case") - (let ((match-val (get frame "match-val")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if (nil? match-val) - ;; First step: match-val just evaluated - (sf-case-step-loop value remaining fenv rest-k) - ;; Subsequent: test clause evaluated - (sf-case-step-loop match-val remaining fenv rest-k))) - - ;; --- ThreadFirstFrame --- - (= ft "thread") - (let ((remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if (empty? remaining) - (make-cek-value value fenv rest-k) - ;; Apply next form to value - (let ((form (first remaining)) - (rest-forms (rest remaining)) - (new-kont (if (empty? (rest remaining)) rest-k - (kont-push (make-thread-frame (rest remaining) fenv) rest-k)))) - ;; Check if form is a HO call like (map fn) - (if (and (= (type-of form) "list") - (not (empty? form)) - (= (type-of (first form)) "symbol") - (ho-form-name? (symbol-name (first form)))) - ;; HO form — splice value as quoted arg, dispatch via CEK - (make-cek-state - (cons (first form) (cons (list 'quote value) (rest form))) - fenv new-kont) - ;; Normal: tree-walk eval + apply - (let ((result (if (= (type-of form) "list") - (let ((f (trampoline (eval-expr (first form) fenv))) - (rargs (map (fn (a) (trampoline (eval-expr a fenv))) (rest form))) - (all-args (cons value rargs))) - (cond - (and (callable? f) (not (lambda? f))) (apply f all-args) - (lambda? f) (trampoline (call-lambda f all-args fenv)) - :else (error (str "-> form not callable: " (inspect f))))) - (let ((f (trampoline (eval-expr form fenv)))) - (cond - (and (callable? f) (not (lambda? f))) (f value) - (lambda? f) (trampoline (call-lambda f (list value) fenv)) - :else (error (str "-> form not callable: " (inspect f)))))))) - (if (empty? rest-forms) - (make-cek-value result fenv rest-k) - (make-cek-value result fenv - (kont-push (make-thread-frame rest-forms fenv) rest-k)))))))) - - ;; --- ArgFrame: head or arg evaluated --- - (= ft "arg") - (let ((f (get frame "f")) - (evaled (get frame "evaled")) - (remaining (get frame "remaining")) - (fenv (get frame "env")) - (raw-args (get frame "raw-args")) - (hname (get frame "head-name"))) - (if (nil? f) - ;; Head just evaluated — value is the function - (do - ;; Strict mode: check arg types for named primitives - (when (and *strict* hname) - (strict-check-args hname (list))) - (if (empty? remaining) - ;; No args — call immediately - (continue-with-call value (list) fenv raw-args rest-k) - ;; Start evaluating args - (make-cek-state - (first remaining) fenv - (kont-push - (make-arg-frame value (list) (rest remaining) fenv raw-args hname) - rest-k)))) - ;; An arg was evaluated — accumulate - (let ((new-evaled (append evaled (list value)))) - (if (empty? remaining) - ;; All args evaluated — strict check then call - (do - (when (and *strict* hname) - (strict-check-args hname new-evaled)) - (continue-with-call f new-evaled fenv raw-args rest-k)) - ;; Next arg - (make-cek-state - (first remaining) fenv - (kont-push - (make-arg-frame f new-evaled (rest remaining) fenv raw-args hname) - rest-k)))))) - - ;; --- DictFrame: value evaluated --- - (= ft "dict") - (let ((remaining (get frame "remaining")) - (results (get frame "results")) - (fenv (get frame "env"))) - ;; Last result entry is (key) — append value to make (key val) - (let ((last-result (last results)) - (completed (append (slice results 0 (dec (len results))) - (list (list (first last-result) value))))) - (if (empty? remaining) - ;; All done — build dict - (let ((d (dict))) - (for-each - (fn (pair) (dict-set! d (first pair) (nth pair 1))) - completed) - (make-cek-value d fenv rest-k)) - ;; Next entry - (let ((next-entry (first remaining))) - (make-cek-state - (nth next-entry 1) fenv - (kont-push - (make-dict-frame - (rest remaining) - (append completed (list (list (first next-entry)))) - fenv) - rest-k)))))) - - ;; --- HoSetupFrame: evaluating HO form arguments --- - (= ft "ho-setup") - (let ((ho-type (get frame "ho-type")) - (remaining (get frame "remaining")) - (evaled (append (get frame "evaled") (list value))) - (fenv (get frame "env"))) - (if (empty? remaining) - ;; All args evaluated — dispatch to iteration - (ho-setup-dispatch ho-type evaled fenv rest-k) - ;; More args to evaluate - (make-cek-state - (first remaining) fenv - (kont-push - (make-ho-setup-frame ho-type (rest remaining) evaled fenv) - rest-k)))) - - ;; --- ResetFrame: body evaluated normally (no shift) --- - (= ft "reset") - (make-cek-value value env rest-k) - - ;; --- DerefFrame: deref argument evaluated --- - (= ft "deref") - (let ((val value) - (fenv (get frame "env"))) - (if (not (signal? val)) - ;; Not a signal: pass through - (make-cek-value val fenv rest-k) - ;; Signal: check for ReactiveResetFrame - (if (has-reactive-reset-frame? rest-k) - ;; Perform reactive shift - (reactive-shift-deref val fenv rest-k) - ;; No reactive-reset: normal deref (scope-based tracking) - (do - (let ((ctx (context "sx-reactive" nil))) - (when ctx - (let ((dep-list (get ctx "deps")) - (notify-fn (get ctx "notify"))) - (when (not (contains? dep-list val)) - (append! dep-list val) - (signal-add-sub! val notify-fn))))) - (make-cek-value (signal-value val) fenv rest-k))))) - - ;; --- ReactiveResetFrame: expression completed --- - (= ft "reactive-reset") - (let ((update-fn (get frame "update-fn")) - (first? (get frame "first-render"))) - ;; On re-render (not first), call update-fn with new value - (when (and update-fn (not first?)) - (cek-call update-fn (list value))) - (make-cek-value value env rest-k)) - - ;; --- ScopeFrame: body result --- - (= ft "scope") - (let ((name (get frame "name")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if (empty? remaining) - (do (scope-pop! name) - (make-cek-value value fenv rest-k)) - (make-cek-state - (first remaining) fenv - (kont-push - (make-scope-frame name (rest remaining) fenv) - rest-k)))) - - ;; --- ProvideFrame: body expression evaluated --- - (= ft "provide") - (let ((remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if (empty? remaining) - ;; Body done — return value, frame consumed - (make-cek-value value fenv rest-k) - ;; More body expressions — keep frame on kont - (make-cek-state - (first remaining) fenv - (kont-push - (make-provide-frame - (get frame "name") (get frame "value") - (rest remaining) fenv) - rest-k)))) - - ;; --- ScopeAccFrame: body expression evaluated --- - (= ft "scope-acc") - (let ((remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if (empty? remaining) - ;; Body done — return value, frame consumed - (make-cek-value value fenv rest-k) - ;; More body expressions — carry emitted list forward - (make-cek-state - (first remaining) fenv - (kont-push - (let ((new-frame (make-scope-acc-frame - (get frame "name") (get frame "value") - (rest remaining) fenv))) - ;; Preserve accumulated emitted from current frame - (dict-set! new-frame "emitted" (get frame "emitted")) - new-frame) - rest-k)))) - - ;; --- MapFrame: callback result for map/map-indexed --- - (= ft "map") - (let ((f (get frame "f")) - (remaining (get frame "remaining")) - (results (get frame "results")) - (indexed (get frame "indexed")) - (fenv (get frame "env"))) - (let ((new-results (append results (list value)))) - (if (empty? remaining) - (make-cek-value new-results fenv rest-k) - (let ((call-args (if indexed - (list (len new-results) (first remaining)) - (list (first remaining)))) - (next-frame (if indexed - (make-map-indexed-frame f (rest remaining) new-results fenv) - (make-map-frame f (rest remaining) new-results fenv)))) - (continue-with-call f call-args fenv (list) - (kont-push next-frame rest-k)))))) - - ;; --- FilterFrame: predicate result --- - (= ft "filter") - (let ((f (get frame "f")) - (remaining (get frame "remaining")) - (results (get frame "results")) - (current-item (get frame "current-item")) - (fenv (get frame "env"))) - (let ((new-results (if value - (append results (list current-item)) - results))) - (if (empty? remaining) - (make-cek-value new-results fenv rest-k) - (continue-with-call f (list (first remaining)) fenv (list) - (kont-push (make-filter-frame f (rest remaining) new-results (first remaining) fenv) rest-k))))) - - ;; --- ReduceFrame: accumulator step --- - (= ft "reduce") - (let ((f (get frame "f")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if (empty? remaining) - (make-cek-value value fenv rest-k) - (continue-with-call f (list value (first remaining)) fenv (list) - (kont-push (make-reduce-frame f (rest remaining) fenv) rest-k)))) - - ;; --- ForEachFrame: side effect, discard result --- - (= ft "for-each") - (let ((f (get frame "f")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if (empty? remaining) + (if + (and value (not (nil? value))) + (let + ((body (get frame "body")) (fenv (get frame "env"))) + (if + (empty? body) (make-cek-value nil fenv rest-k) - (continue-with-call f (list (first remaining)) fenv (list) - (kont-push (make-for-each-frame f (rest remaining) fenv) rest-k)))) - - ;; --- SomeFrame: short-circuit on first truthy --- + (if + (= (len body) 1) + (make-cek-state (first body) fenv rest-k) + (make-cek-state + (first body) + fenv + (kont-push (make-begin-frame (rest body) fenv) rest-k))))) + (make-cek-value nil env rest-k)) + (= ft "begin") + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) + (if + (= (len remaining) 1) + (make-cek-state (first remaining) fenv rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-begin-frame (rest remaining) fenv) + rest-k))))) + (= ft "let") + (let + ((name (get frame "name")) + (remaining (get frame "remaining")) + (body (get frame "body")) + (local (get frame "env"))) + (env-bind! local name value) + (if + (empty? remaining) + (step-sf-begin body local rest-k) + (let + ((next-binding (first remaining)) + (vname + (if + (= (type-of (first next-binding)) "symbol") + (symbol-name (first next-binding)) + (first next-binding)))) + (make-cek-state + (nth next-binding 1) + local + (kont-push + (make-let-frame vname (rest remaining) body local) + rest-k))))) + (= ft "define") + (let + ((name (get frame "name")) + (fenv (get frame "env")) + (has-effects (get frame "has-effects")) + (effect-list (get frame "effect-list"))) + (when + (and (lambda? value) (nil? (lambda-name value))) + (set-lambda-name! value name)) + (env-bind! fenv name value) + (when + has-effects + (let + ((effect-names (if (= (type-of effect-list) "list") (map (fn (e) (if (= (type-of e) "symbol") (symbol-name e) (str e))) effect-list) (list (str effect-list)))) + (effect-anns + (if + (env-has? fenv "*effect-annotations*") + (env-get fenv "*effect-annotations*") + (dict)))) + (dict-set! effect-anns name effect-names) + (env-bind! fenv "*effect-annotations*" effect-anns))) + (make-cek-value value fenv rest-k)) + (= ft "set") + (let + ((name (get frame "name")) (fenv (get frame "env"))) + (env-set! fenv name value) + (make-cek-value value env rest-k)) + (= ft "and") + (if + (not value) + (make-cek-value value env rest-k) + (let + ((remaining (get frame "remaining"))) + (if + (empty? remaining) + (make-cek-value value env rest-k) + (make-cek-state + (first remaining) + (get frame "env") + (if + (= (len remaining) 1) + rest-k + (kont-push + (make-and-frame (rest remaining) (get frame "env")) + rest-k)))))) + (= ft "or") + (if + value + (make-cek-value value env rest-k) + (let + ((remaining (get frame "remaining"))) + (if + (empty? remaining) + (make-cek-value false env rest-k) + (make-cek-state + (first remaining) + (get frame "env") + (if + (= (len remaining) 1) + rest-k + (kont-push + (make-or-frame (rest remaining) (get frame "env")) + rest-k)))))) + (= ft "cond") + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env")) + (scheme? (get frame "scheme"))) + (if + scheme? + (if + value + (make-cek-state (nth (first remaining) 1) fenv rest-k) + (let + ((next-clauses (rest remaining))) + (if + (empty? next-clauses) + (make-cek-value nil fenv rest-k) + (let + ((next-clause (first next-clauses)) + (next-test (first next-clause))) + (if + (is-else-clause? next-test) + (make-cek-state (nth next-clause 1) fenv rest-k) + (make-cek-state + next-test + fenv + (kont-push + (make-cond-frame next-clauses fenv true) + rest-k))))))) + (if + value + (make-cek-state (nth remaining 1) fenv rest-k) + (let + ((next (slice remaining 2))) + (if + (< (len next) 2) + (make-cek-value nil fenv rest-k) + (let + ((next-test (first next))) + (if + (is-else-clause? next-test) + (make-cek-state (nth next 1) fenv rest-k) + (make-cek-state + next-test + fenv + (kont-push + (make-cond-frame next fenv false) + rest-k))))))))) + (= ft "case") + (let + ((match-val (get frame "match-val")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (nil? match-val) + (sf-case-step-loop value remaining fenv rest-k) + (sf-case-step-loop match-val remaining fenv rest-k))) + (= ft "thread") + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) + (let + ((form (first remaining)) + (rest-forms (rest remaining)) + (new-kont + (if + (empty? (rest remaining)) + rest-k + (kont-push + (make-thread-frame (rest remaining) fenv) + rest-k)))) + (if + (and + (= (type-of form) "list") + (not (empty? form)) + (= (type-of (first form)) "symbol") + (ho-form-name? (symbol-name (first form)))) + (make-cek-state + (cons + (first form) + (cons (list (quote quote) value) (rest form))) + fenv + new-kont) + (let + ((result (if (= (type-of form) "list") (let ((f (trampoline (eval-expr (first form) fenv))) (rargs (map (fn (a) (trampoline (eval-expr a fenv))) (rest form))) (all-args (cons value rargs))) (cond (and (callable? f) (not (lambda? f))) (apply f all-args) (lambda? f) (trampoline (call-lambda f all-args fenv)) :else (error (str "-> form not callable: " (inspect f))))) (let ((f (trampoline (eval-expr form fenv)))) (cond (and (callable? f) (not (lambda? f))) (f value) (lambda? f) (trampoline (call-lambda f (list value) fenv)) :else (error (str "-> form not callable: " (inspect f)))))))) + (if + (empty? rest-forms) + (make-cek-value result fenv rest-k) + (make-cek-value + result + fenv + (kont-push + (make-thread-frame rest-forms fenv) + rest-k)))))))) + (= ft "arg") + (let + ((f (get frame "f")) + (evaled (get frame "evaled")) + (remaining (get frame "remaining")) + (fenv (get frame "env")) + (raw-args (get frame "raw-args")) + (hname (get frame "head-name"))) + (if + (nil? f) + (do + (when + (and *strict* hname) + (strict-check-args hname (list))) + (if + (empty? remaining) + (continue-with-call value (list) fenv raw-args rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-arg-frame + value + (list) + (rest remaining) + fenv + raw-args + hname) + rest-k)))) + (let + ((new-evaled (append evaled (list value)))) + (if + (empty? remaining) + (do + (when + (and *strict* hname) + (strict-check-args hname new-evaled)) + (continue-with-call f new-evaled fenv raw-args rest-k)) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-arg-frame + f + new-evaled + (rest remaining) + fenv + raw-args + hname) + rest-k)))))) + (= ft "dict") + (let + ((remaining (get frame "remaining")) + (results (get frame "results")) + (fenv (get frame "env"))) + (let + ((last-result (last results)) + (completed + (append + (slice results 0 (dec (len results))) + (list (list (first last-result) value))))) + (if + (empty? remaining) + (let + ((d (dict))) + (for-each + (fn (pair) (dict-set! d (first pair) (nth pair 1))) + completed) + (make-cek-value d fenv rest-k)) + (let + ((next-entry (first remaining))) + (make-cek-state + (nth next-entry 1) + fenv + (kont-push + (make-dict-frame + (rest remaining) + (append + completed + (list (list (first next-entry)))) + fenv) + rest-k)))))) + (= ft "ho-setup") + (let + ((ho-type (get frame "ho-type")) + (remaining (get frame "remaining")) + (evaled (append (get frame "evaled") (list value))) + (fenv (get frame "env"))) + (if + (empty? remaining) + (ho-setup-dispatch ho-type evaled fenv rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-ho-setup-frame ho-type (rest remaining) evaled fenv) + rest-k)))) + (= ft "reset") + (make-cek-value value env rest-k) + (= ft "deref") + (let + ((val value) (fenv (get frame "env"))) + (if + (not (signal? val)) + (make-cek-value val fenv rest-k) + (if + (has-reactive-reset-frame? rest-k) + (reactive-shift-deref val fenv rest-k) + (do + (let + ((ctx (context "sx-reactive" nil))) + (when + ctx + (let + ((dep-list (get ctx "deps")) + (notify-fn (get ctx "notify"))) + (when + (not (contains? dep-list val)) + (append! dep-list val) + (signal-add-sub! val notify-fn))))) + (make-cek-value (signal-value val) fenv rest-k))))) + (= ft "reactive-reset") + (let + ((update-fn (get frame "update-fn")) + (first? (get frame "first-render"))) + (when + (and update-fn (not first?)) + (cek-call update-fn (list value))) + (make-cek-value value env rest-k)) + (= ft "scope") + (let + ((name (get frame "name")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (do (scope-pop! name) (make-cek-value value fenv rest-k)) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-scope-frame name (rest remaining) fenv) + rest-k)))) + (= ft "provide") + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-provide-frame + (get frame "name") + (get frame "value") + (rest remaining) + fenv) + rest-k)))) + (= ft "scope-acc") + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (let + ((new-frame (make-scope-acc-frame (get frame "name") (get frame "value") (rest remaining) fenv))) + (dict-set! new-frame "emitted" (get frame "emitted")) + new-frame) + rest-k)))) + (= ft "map") + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (results (get frame "results")) + (indexed (get frame "indexed")) + (fenv (get frame "env"))) + (let + ((new-results (append results (list value)))) + (if + (empty? remaining) + (make-cek-value new-results fenv rest-k) + (let + ((call-args (if indexed (list (len new-results) (first remaining)) (list (first remaining)))) + (next-frame + (if + indexed + (make-map-indexed-frame + f + (rest remaining) + new-results + fenv) + (make-map-frame f (rest remaining) new-results fenv)))) + (continue-with-call + f + call-args + fenv + (list) + (kont-push next-frame rest-k)))))) + (= ft "filter") + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (results (get frame "results")) + (current-item (get frame "current-item")) + (fenv (get frame "env"))) + (let + ((new-results (if value (append results (list current-item)) results))) + (if + (empty? remaining) + (make-cek-value new-results fenv rest-k) + (continue-with-call + f + (list (first remaining)) + fenv + (list) + (kont-push + (make-filter-frame + f + (rest remaining) + new-results + (first remaining) + fenv) + rest-k))))) + (= ft "reduce") + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) + (continue-with-call + f + (list value (first remaining)) + fenv + (list) + (kont-push + (make-reduce-frame f (rest remaining) fenv) + rest-k)))) + (= ft "for-each") + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value nil fenv rest-k) + (continue-with-call + f + (list (first remaining)) + fenv + (list) + (kont-push + (make-for-each-frame f (rest remaining) fenv) + rest-k)))) (= ft "some") - (let ((f (get frame "f")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if value - (make-cek-value value fenv rest-k) - (if (empty? remaining) - (make-cek-value false fenv rest-k) - (continue-with-call f (list (first remaining)) fenv (list) - (kont-push (make-some-frame f (rest remaining) fenv) rest-k))))) - - ;; --- EveryFrame: short-circuit on first falsy --- - (= ft "every") - (let ((f (get frame "f")) - (remaining (get frame "remaining")) - (fenv (get frame "env"))) - (if (not value) + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + value + (make-cek-value value fenv rest-k) + (if + (empty? remaining) (make-cek-value false fenv rest-k) - (if (empty? remaining) - (make-cek-value true fenv rest-k) - (continue-with-call f (list (first remaining)) fenv (list) - (kont-push (make-every-frame f (rest remaining) fenv) rest-k))))) - + (continue-with-call + f + (list (first remaining)) + fenv + (list) + (kont-push + (make-some-frame f (rest remaining) fenv) + rest-k))))) + (= ft "every") + (let + ((f (get frame "f")) + (remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (not value) + (make-cek-value false fenv rest-k) + (if + (empty? remaining) + (make-cek-value true fenv rest-k) + (continue-with-call + f + (list (first remaining)) + fenv + (list) + (kont-push + (make-every-frame f (rest remaining) fenv) + rest-k))))) + (= ft "handler") + (let + ((remaining (get frame "remaining")) + (fenv (get frame "env"))) + (if + (empty? remaining) + (make-cek-value value fenv rest-k) + (make-cek-state + (first remaining) + fenv + (kont-push + (make-handler-frame + (get frame "f") + (rest remaining) + fenv) + rest-k)))) + (= ft "restart") + (make-cek-value value env rest-k) + (= ft "signal-return") + (let + ((saved-kont (get frame "f"))) + (make-cek-value value (get frame "env") saved-kont)) + (= ft "comp-trace") + (make-cek-value value env rest-k) :else (error (str "Unknown frame type: " ft)))))))) - -;; -------------------------------------------------------------------------- -;; 9. Helper: continue with function call -;; -------------------------------------------------------------------------- - -(define continue-with-call - (fn (f args env raw-args kont) +(define + continue-with-call + (fn + (f args env raw-args kont) (cond - ;; Continuation — run captured delimited continuation, return result to caller. - ;; Multi-shot: each invocation runs captured frames to completion via nested - ;; cek-run, then returns the result to the caller's kont. (continuation? f) - (let ((arg (if (empty? args) nil (first args))) - (cont-data (continuation-data f))) - (let ((captured (get cont-data "captured"))) - ;; Run ONLY the captured frames (delimited by reset). - ;; Empty kont after captured = the continuation terminates and returns. - (let ((result (cek-run (make-cek-value arg env captured)))) - (make-cek-value result env kont)))) - - ;; Native callable - (and (callable? f) (not (lambda? f)) (not (component? f)) (not (island? f))) - (make-cek-value (apply f args) env kont) - - ;; Lambda — bind params, evaluate body + (let + ((arg (if (empty? args) nil (first args))) + (cont-data (continuation-data f))) + (let + ((captured (get cont-data "captured"))) + (let + ((result (cek-run (make-cek-value arg env captured)))) + (make-cek-value result env kont)))) + (and + (callable? f) + (not (lambda? f)) + (not (component? f)) + (not (island? f))) + (make-cek-value (apply f args) env kont) (lambda? f) - (let ((params (lambda-params f)) - (local (env-merge (lambda-closure f) env))) - (if (> (len args) (len params)) - (error (str (or (lambda-name f) "lambda") - " expects " (len params) " args, got " (len args))) - (do - (for-each - (fn (pair) (env-bind! local (first pair) (nth pair 1))) - (zip params args)) - (for-each - (fn (p) (env-bind! local p nil)) - (slice params (len args))) - (make-cek-state (lambda-body f) local kont)))) - - ;; Component — parse kwargs, bind, evaluate body + (let + ((params (lambda-params f)) + (local (env-merge (lambda-closure f) env))) + (if + (> (len args) (len params)) + (error + (str + (or (lambda-name f) "lambda") + " expects " + (len params) + " args, got " + (len args))) + (do + (for-each + (fn (pair) (env-bind! local (first pair) (nth pair 1))) + (zip params args)) + (for-each + (fn (p) (env-bind! local p nil)) + (slice params (len args))) + (make-cek-state (lambda-body f) local kont)))) (or (component? f) (island? f)) - (let ((parsed (parse-keyword-args raw-args env)) - (kwargs (first parsed)) - (children (nth parsed 1)) - (local (env-merge (component-closure f) env))) - (for-each - (fn (p) (env-bind! local p (or (dict-get kwargs p) nil))) - (component-params f)) - (when (component-has-children? f) - (env-bind! local "children" children)) - (make-cek-state (component-body f) local kont)) - + (let + ((parsed (parse-keyword-args raw-args env)) + (kwargs (first parsed)) + (children (nth parsed 1)) + (local (env-merge (component-closure f) env))) + (for-each + (fn (p) (env-bind! local p (or (dict-get kwargs p) nil))) + (component-params f)) + (when + (component-has-children? f) + (env-bind! local "children" children)) + (make-cek-state + (component-body f) + local + (kont-push + (make-comp-trace-frame (component-name f) (component-file f)) + kont))) :else (error (str "Not callable: " (inspect f)))))) - - -;; -------------------------------------------------------------------------- -;; 10. Case step loop helper -;; -------------------------------------------------------------------------- - -(define sf-case-step-loop - (fn (match-val clauses env kont) - (if (< (len clauses) 2) +(define + sf-case-step-loop + (fn + (match-val clauses env kont) + (if + (< (len clauses) 2) (make-cek-value nil env kont) - (let ((test (first clauses)) - (body (nth clauses 1))) - (if (is-else-clause? test) + (let + ((test (first clauses)) (body (nth clauses 1))) + (if + (is-else-clause? test) (make-cek-state body env kont) - ;; Evaluate test expression - (let ((test-val (trampoline (eval-expr test env)))) - (if (= match-val test-val) + (let + ((test-val (trampoline (eval-expr test env)))) + (if + (= match-val test-val) (make-cek-state body env kont) (sf-case-step-loop match-val (slice clauses 2) env kont)))))))) +(define + eval-expr-cek + (fn (expr env) (cek-run (make-cek-state expr env (list))))) -;; -------------------------------------------------------------------------- -;; 11. Compatibility wrapper — eval-expr-cek -;; -------------------------------------------------------------------------- -;; -;; Drop-in replacement for eval-expr. Creates a CEK state and runs. -;; All downstream code (adapters, services) works unchanged. +(define + trampoline-cek + (fn + (val) + (if (thunk? val) (eval-expr-cek (thunk-expr val) (thunk-env val)) val))) -(define eval-expr-cek - (fn (expr env) - (cek-run (make-cek-state expr env (list))))) +(define + eval-expr + (fn (expr (env :as dict)) (cek-run (make-cek-state expr env (list))))) -(define trampoline-cek - (fn (val) - ;; In CEK mode, thunks are not produced — values are immediate. - ;; But for compatibility, resolve any remaining thunks. - (if (thunk? val) - (eval-expr-cek (thunk-expr val) (thunk-env val)) - val))) - - -;; ************************************************************************** -;; eval-expr / trampoline — canonical definitions (after cek-run is defined) -;; ************************************************************************** -;; -;; These override the forward declarations from Part 2. All evaluation -;; goes through the CEK machine. The CEK fixups in the host platform -;; may further override these (e.g., to make cek-run iterative). - -(define eval-expr - (fn (expr (env :as dict)) - (cek-run (make-cek-state expr env (list))))) - -(define trampoline - (fn (val) - (if (thunk? val) - (eval-expr (thunk-expr val) (thunk-env val)) - val))) +(define + trampoline + (fn + (val) + (if (thunk? val) (eval-expr (thunk-expr val) (thunk-env val)) val))) diff --git a/spec/render.sx b/spec/render.sx index 039c328f..e709bbef 100644 --- a/spec/render.sx +++ b/spec/render.sx @@ -1,101 +1,229 @@ -;; ========================================================================== -;; render.sx — Core rendering specification -;; -;; Shared registries and utilities used by all rendering adapters. -;; This file defines WHAT is renderable (tag registries, attribute rules) -;; and HOW arguments are parsed — but not the output format. -;; -;; Adapters: -;; adapter-html.sx — HTML string output (server) -;; adapter-sx.sx — SX wire format output (server → client) -;; adapter-dom.sx — Live DOM node output (browser) -;; -;; Each adapter imports these shared definitions and provides its own -;; render entry point (render-to-html, render-to-sx, render-to-dom). -;; ========================================================================== - - -;; -------------------------------------------------------------------------- -;; HTML tag registry -;; -------------------------------------------------------------------------- -;; Tags known to the renderer. Unknown names are treated as function calls. -;; Void elements self-close (no children). Boolean attrs emit name only. - -(define HTML_TAGS +(define + HTML_TAGS (list - ;; Document - "html" "head" "body" "title" "meta" "link" "script" "style" "noscript" - ;; Sections - "header" "nav" "main" "section" "article" "aside" "footer" - "h1" "h2" "h3" "h4" "h5" "h6" "hgroup" - ;; Block - "div" "p" "blockquote" "pre" "figure" "figcaption" "address" "details" "summary" - ;; Inline - "a" "span" "em" "strong" "small" "b" "i" "u" "s" "mark" "sub" "sup" - "abbr" "cite" "code" "kbd" "samp" "var" "time" "br" "wbr" "hr" - ;; Lists - "ul" "ol" "li" "dl" "dt" "dd" - ;; Tables - "table" "thead" "tbody" "tfoot" "tr" "th" "td" "caption" "colgroup" "col" - ;; Forms - "form" "input" "textarea" "select" "option" "optgroup" "button" "label" - "fieldset" "legend" "output" "datalist" - ;; Media - "img" "video" "audio" "source" "picture" "canvas" "iframe" - ;; SVG - "svg" "math" "path" "circle" "ellipse" "rect" "line" "polyline" "polygon" - "text" "tspan" "g" "defs" "use" "clipPath" "mask" "pattern" - "linearGradient" "radialGradient" "stop" "filter" - "feGaussianBlur" "feOffset" "feBlend" "feColorMatrix" "feComposite" - "feMerge" "feMergeNode" "feTurbulence" - "feComponentTransfer" "feFuncR" "feFuncG" "feFuncB" "feFuncA" - "feDisplacementMap" "feFlood" "feImage" "feMorphology" - "feSpecularLighting" "feDiffuseLighting" - "fePointLight" "feSpotLight" "feDistantLight" - "animate" "animateTransform" "foreignObject" - ;; Other - "template" "slot" "dialog" "menu")) + "html" + "head" + "body" + "title" + "meta" + "link" + "script" + "style" + "noscript" + "header" + "nav" + "main" + "section" + "article" + "aside" + "footer" + "h1" + "h2" + "h3" + "h4" + "h5" + "h6" + "hgroup" + "div" + "p" + "blockquote" + "pre" + "figure" + "figcaption" + "address" + "details" + "summary" + "a" + "span" + "em" + "strong" + "small" + "b" + "i" + "u" + "s" + "mark" + "sub" + "sup" + "abbr" + "cite" + "code" + "kbd" + "samp" + "var" + "time" + "br" + "wbr" + "hr" + "ul" + "ol" + "li" + "dl" + "dt" + "dd" + "table" + "thead" + "tbody" + "tfoot" + "tr" + "th" + "td" + "caption" + "colgroup" + "col" + "form" + "input" + "textarea" + "select" + "option" + "optgroup" + "button" + "label" + "fieldset" + "legend" + "output" + "datalist" + "img" + "video" + "audio" + "source" + "picture" + "canvas" + "iframe" + "svg" + "math" + "path" + "circle" + "ellipse" + "rect" + "line" + "polyline" + "polygon" + "text" + "tspan" + "g" + "defs" + "use" + "clipPath" + "mask" + "pattern" + "linearGradient" + "radialGradient" + "stop" + "filter" + "feGaussianBlur" + "feOffset" + "feBlend" + "feColorMatrix" + "feComposite" + "feMerge" + "feMergeNode" + "feTurbulence" + "feComponentTransfer" + "feFuncR" + "feFuncG" + "feFuncB" + "feFuncA" + "feDisplacementMap" + "feFlood" + "feImage" + "feMorphology" + "feSpecularLighting" + "feDiffuseLighting" + "fePointLight" + "feSpotLight" + "feDistantLight" + "animate" + "animateTransform" + "foreignObject" + "template" + "slot" + "dialog" + "menu")) -(define VOID_ELEMENTS - (list "area" "base" "br" "col" "embed" "hr" "img" "input" - "link" "meta" "param" "source" "track" "wbr")) +(define + VOID_ELEMENTS + (list + "area" + "base" + "br" + "col" + "embed" + "hr" + "img" + "input" + "link" + "meta" + "param" + "source" + "track" + "wbr")) -(define BOOLEAN_ATTRS - (list "async" "autofocus" "autoplay" "checked" "controls" "default" - "defer" "disabled" "formnovalidate" "hidden" "inert" "ismap" - "loop" "multiple" "muted" "nomodule" "novalidate" "open" - "playsinline" "readonly" "required" "reversed" "selected")) +(define + BOOLEAN_ATTRS + (list + "async" + "autofocus" + "autoplay" + "checked" + "controls" + "default" + "defer" + "disabled" + "formnovalidate" + "hidden" + "inert" + "ismap" + "loop" + "multiple" + "muted" + "nomodule" + "novalidate" + "open" + "playsinline" + "readonly" + "required" + "reversed" + "selected")) - -;; -------------------------------------------------------------------------- -;; Shared utilities -;; -------------------------------------------------------------------------- - -;; Extension point for definition forms — modules append names here. -;; Survives spec reloads (no function wrapping needed). (define *definition-form-extensions* (list)) -(define definition-form? :effects [] - (fn ((name :as string)) - (or (= name "define") (= name "defcomp") (= name "defisland") - (= name "defmacro") (= name "defstyle") - (= name "deftype") (= name "defeffect") - (contains? *definition-form-extensions* name)))) +(define + definition-form? + :effects () + (fn + ((name :as string)) + (or + (= name "define") + (= name "defcomp") + (= name "defisland") + (= name "defmacro") + (= name "defstyle") + (= name "deftype") + (= name "defeffect") + (contains? *definition-form-extensions* name)))) - -(define parse-element-args :effects [render] - (fn ((args :as list) (env :as dict)) - ;; Parse (:key val :key2 val2 child1 child2) into (attrs-dict children-list) - (let ((attrs (dict)) - (children (list))) +(define + parse-element-args + :effects (render) + (fn + ((args :as list) (env :as dict)) + (let + ((attrs (dict)) (children (list))) (reduce - (fn ((state :as dict) arg) - (let ((skip (get state "skip"))) - (if skip + (fn + ((state :as dict) arg) + (let + ((skip (get state "skip"))) + (if + skip (assoc state "skip" false "i" (inc (get state "i"))) - (if (and (= (type-of arg) "keyword") - (< (inc (get state "i")) (len args))) - (let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) + (if + (and + (= (type-of arg) "keyword") + (< (inc (get state "i")) (len args))) + (let + ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (dict-set! attrs (keyword-name arg) val) (assoc state "skip" true "i" (inc (get state "i")))) (do @@ -105,193 +233,168 @@ args) (list attrs children)))) - -(define render-attrs :effects [] - (fn ((attrs :as dict)) - ;; Render an attrs dict to an HTML attribute string. - ;; Used by adapter-html.sx and adapter-sx.sx. - (join "" +(define + render-attrs + :effects () + (fn + ((attrs :as dict)) + (join + "" (map - (fn ((key :as string)) - (let ((val (dict-get attrs key))) + (fn + ((key :as string)) + (let + ((val (dict-get attrs key))) (cond - ;; Boolean attrs (and (contains? BOOLEAN_ATTRS key) val) - (str " " key) + (str " " key) (and (contains? BOOLEAN_ATTRS key) (not val)) - "" - ;; Nil values — skip - (nil? val) "" - ;; Normal attr + "" + (nil? val) + "" :else (str " " key "=\"" (escape-attr (str val)) "\"")))) (keys attrs))))) - -;; -------------------------------------------------------------------------- -;; Render adapter helpers -;; -------------------------------------------------------------------------- -;; Shared by HTML and DOM adapters for evaluating control forms during -;; rendering. Unlike sf-cond (eval.sx) which returns a thunk for TCO, -;; eval-cond returns the unevaluated body expression so the adapter -;; can render it in its own mode (HTML string vs DOM nodes). - -;; eval-cond: find matching cond branch, return unevaluated body expr. -;; Handles both scheme-style ((test body) ...) and clojure-style -;; (test body test body ...). -(define eval-cond :effects [] - (fn ((clauses :as list) (env :as dict)) - (if (cond-scheme? clauses) +(define + eval-cond + :effects () + (fn + ((clauses :as list) (env :as dict)) + (if + (cond-scheme? clauses) (eval-cond-scheme clauses env) (eval-cond-clojure clauses env)))) -(define eval-cond-scheme :effects [] - (fn ((clauses :as list) (env :as dict)) - (if (empty? clauses) +(define + eval-cond-scheme + :effects () + (fn + ((clauses :as list) (env :as dict)) + (if + (empty? clauses) nil - (let ((clause (first clauses)) - (test (first clause)) - (body (nth clause 1))) - (if (is-else-clause? test) + (let + ((clause (first clauses)) + (test (first clause)) + (body (nth clause 1))) + (if + (is-else-clause? test) body - (if (trampoline (eval-expr test env)) + (if + (trampoline (eval-expr test env)) body (eval-cond-scheme (rest clauses) env))))))) -(define eval-cond-clojure :effects [] - (fn ((clauses :as list) (env :as dict)) - (if (< (len clauses) 2) +(define + eval-cond-clojure + :effects () + (fn + ((clauses :as list) (env :as dict)) + (if + (< (len clauses) 2) nil - (let ((test (first clauses)) - (body (nth clauses 1))) - (if (is-else-clause? test) + (let + ((test (first clauses)) (body (nth clauses 1))) + (if + (is-else-clause? test) body - (if (trampoline (eval-expr test env)) + (if + (trampoline (eval-expr test env)) body (eval-cond-clojure (slice clauses 2) env))))))) -;; process-bindings: evaluate let-binding pairs, return extended env. -;; bindings = ((name1 expr1) (name2 expr2) ...) -(define process-bindings :effects [mutation] - (fn ((bindings :as list) (env :as dict)) - ;; env-extend (not merge) — Env is not a dict subclass, so merge() - ;; returns an empty dict, losing all parent scope bindings. - (let ((local (env-extend env))) +(define + process-bindings + :effects (mutation) + (fn + ((bindings :as list) (env :as dict)) + (let + ((local (env-extend env))) (for-each - (fn ((pair :as list)) - (when (and (= (type-of pair) "list") (>= (len pair) 2)) - (let ((name (if (= (type-of (first pair)) "symbol") - (symbol-name (first pair)) - (str (first pair))))) - (env-bind! local name (trampoline (eval-expr (nth pair 1) local)))))) + (fn + ((pair :as list)) + (when + (and (= (type-of pair) "list") (>= (len pair) 2)) + (let + ((name (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair))))) + (env-bind! + local + name + (trampoline (eval-expr (nth pair 1) local)))))) bindings) local))) - -;; -------------------------------------------------------------------------- -;; is-render-expr? — check if expression is a rendering form -;; -------------------------------------------------------------------------- -;; Used by eval-list to dispatch rendering forms to the active adapter -;; (HTML, SX wire, or DOM) rather than evaluating them as function calls. - -(define is-render-expr? :effects [] - (fn (expr) - (if (or (not (= (type-of expr) "list")) (empty? expr)) +(define + is-render-expr? + :effects () + (fn + (expr) + (if + (or (not (= (type-of expr) "list")) (empty? expr)) false - (let ((h (first expr))) - (if (not (= (type-of h) "symbol")) + (let + ((h (first expr))) + (if + (not (= (type-of h) "symbol")) false - (let ((n (symbol-name h))) - (or (= n "<>") - (= n "raw!") - (starts-with? n "~") - (starts-with? n "html:") - (contains? HTML_TAGS n) - (and (> (index-of n "-") 0) - (> (len expr) 1) - (= (type-of (nth expr 1)) "keyword"))))))))) + (let + ((n (symbol-name h))) + (or + (= n "<>") + (= n "raw!") + (starts-with? n "~") + (starts-with? n "html:") + (contains? HTML_TAGS n) + (and + (> (index-of n "-") 0) + (> (len expr) 1) + (= (type-of (nth expr 1)) "keyword"))))))))) - -;; -------------------------------------------------------------------------- -;; Spread — attribute injection from children into parent elements -;; -------------------------------------------------------------------------- -;; -;; A spread value is a dict of attributes that, when returned as a child -;; of an HTML element, merges its attrs onto the parent element. -;; This enables components to inject classes/styles/data-attrs onto their -;; parent without the parent knowing about the specific attrs. -;; -;; merge-spread-attrs: merge a spread's attrs into an element's attrs dict. -;; Class values are joined (space-separated); others overwrite. -;; Mutates the target attrs dict in place. - -(define merge-spread-attrs :effects [mutation] - (fn ((target :as dict) (spread-dict :as dict)) +(define + merge-spread-attrs + :effects (mutation) + (fn + ((target :as dict) (spread-dict :as dict)) (for-each - (fn ((key :as string)) - (let ((val (dict-get spread-dict key))) - (if (= key "class") - ;; Class: join existing + new with space - (let ((existing (dict-get target "class"))) - (dict-set! target "class" - (if (and existing (not (= existing ""))) + (fn + ((key :as string)) + (let + ((val (dict-get spread-dict key))) + (if + (= key "class") + (let + ((existing (dict-get target "class"))) + (dict-set! + target + "class" + (if + (and existing (not (= existing ""))) (str existing " " val) val))) - ;; Style: join with semicolons - (if (= key "style") - (let ((existing (dict-get target "style"))) - (dict-set! target "style" - (if (and existing (not (= existing ""))) + (if + (= key "style") + (let + ((existing (dict-get target "style"))) + (dict-set! + target + "style" + (if + (and existing (not (= existing ""))) (str existing ";" val) val))) - ;; Everything else: overwrite (dict-set! target key val))))) (keys spread-dict)))) - -;; -------------------------------------------------------------------------- -;; HTML escaping — library functions (pure text processing) -;; -------------------------------------------------------------------------- - -(define escape-html - (fn (s) - (let ((r (str s))) +(define + escape-html + (fn + (s) + (let + ((r (str s))) (set! r (replace r "&" "&")) (set! r (replace r "<" "<")) (set! r (replace r ">" ">")) (set! r (replace r "\"" """)) r))) -(define escape-attr - (fn (s) - (escape-html s))) - - -;; -------------------------------------------------------------------------- -;; Platform interface (shared across adapters) -;; -------------------------------------------------------------------------- -;; -;; Raw HTML (marker type for unescaped content): -;; (raw-html-content r) → unwrap RawHTML marker to string -;; -;; Spread (render-time attribute injection): -;; (make-spread attrs) → Spread value -;; (spread? x) → boolean -;; (spread-attrs s) → dict -;; -;; Render-time accumulators: -;; (collect! bucket value) → void -;; (collected bucket) → list -;; (clear-collected! bucket) → void -;; -;; Scoped effects (scope/provide/context/emit!): -;; (scope-push! name val) → void (general form) -;; (scope-pop! name) → void (general form) -;; (provide-push! name val) → alias for scope-push! -;; (provide-pop! name) → alias for scope-pop! -;; (context name &rest def) → value from nearest scope -;; (emit! name value) → void (append to scope accumulator) -;; (emitted name) → list of emitted values -;; -;; From parser.sx: -;; (sx-serialize val) → SX source string (aliased as serialize above) -;; -------------------------------------------------------------------------- +(define escape-attr (fn (s) (escape-html s))) diff --git a/web/adapter-html.sx b/web/adapter-html.sx index f07bfa26..211a55a0 100644 --- a/web/adapter-html.sx +++ b/web/adapter-html.sx @@ -1,25 +1,554 @@ -(define render-to-html :effects (render) (fn (expr (env :as dict)) (set-render-active! true) (case (type-of expr) "nil" "" "string" (escape-html expr) "number" (str expr) "boolean" (if expr "true" "false") "list" (if (empty? expr) "" (render-list-to-html expr env)) "symbol" (render-value-to-html (trampoline (eval-expr expr env)) env) "keyword" (escape-html (keyword-name expr)) "raw-html" (raw-html-content expr) "spread" (do (scope-emit! "element-attrs" (spread-attrs expr)) "") "thunk" (render-to-html (thunk-expr expr) (thunk-env expr)) :else (render-value-to-html (trampoline (eval-expr expr env)) env)))) +(define + render-to-html + :effects (render) + (fn + (expr (env :as dict)) + (set-render-active! true) + (case + (type-of expr) + "nil" + "" + "string" + (escape-html expr) + "number" + (str expr) + "boolean" + (if expr "true" "false") + "list" + (if (empty? expr) "" (render-list-to-html expr env)) + "symbol" + (render-value-to-html (trampoline (eval-expr expr env)) env) + "keyword" + (escape-html (keyword-name expr)) + "raw-html" + (raw-html-content expr) + "spread" + (do (scope-emit! "element-attrs" (spread-attrs expr)) "") + "thunk" + (render-to-html (thunk-expr expr) (thunk-env expr)) + :else (render-value-to-html (trampoline (eval-expr expr env)) env)))) -(define render-value-to-html :effects (render) (fn (val (env :as dict)) (case (type-of val) "nil" "" "string" (escape-html val) "number" (str val) "boolean" (if val "true" "false") "list" (render-list-to-html val env) "raw-html" (raw-html-content val) "spread" (do (scope-emit! "element-attrs" (spread-attrs val)) "") "thunk" (render-to-html (thunk-expr val) (thunk-env val)) :else (escape-html (str val))))) +(define + render-value-to-html + :effects (render) + (fn + (val (env :as dict)) + (case + (type-of val) + "nil" + "" + "string" + (escape-html val) + "number" + (str val) + "boolean" + (if val "true" "false") + "list" + (render-list-to-html val env) + "raw-html" + (raw-html-content val) + "spread" + (do (scope-emit! "element-attrs" (spread-attrs val)) "") + "thunk" + (render-to-html (thunk-expr val) (thunk-env val)) + :else (escape-html (str val))))) -(define RENDER_HTML_FORMS (list "if" "when" "cond" "case" "let" "let*" "letrec" "begin" "do" "define" "defcomp" "defisland" "defmacro" "defstyle" "deftype" "defeffect" "map" "map-indexed" "filter" "for-each" "scope" "provide")) +(define + RENDER_HTML_FORMS + (list + "if" + "when" + "cond" + "case" + "let" + "let*" + "letrec" + "begin" + "do" + "define" + "defcomp" + "defisland" + "defmacro" + "defstyle" + "deftype" + "defeffect" + "map" + "map-indexed" + "filter" + "for-each" + "scope" + "provide")) -(define render-html-form? :effects () (fn ((name :as string)) (contains? RENDER_HTML_FORMS name))) +(define + render-html-form? + :effects () + (fn ((name :as string)) (contains? RENDER_HTML_FORMS name))) -(define render-list-to-html :effects (render) (fn ((expr :as list) (env :as dict)) (if (empty? expr) "" (let ((head (first expr))) (if (not (= (type-of head) "symbol")) (join "" (map (fn (x) (render-value-to-html x env)) expr)) (let ((name (symbol-name head)) (args (rest expr))) (cond (= name "<>") (join "" (map (fn (x) (render-to-html x env)) args)) (= name "raw!") (join "" (map (fn (x) (str (trampoline (eval-expr x env)))) args)) (= name "lake") (render-html-lake args env) (= name "marsh") (render-html-marsh args env) (or (= name "portal") (= name "error-boundary") (= name "promise-delayed")) (join "" (map (fn (x) (render-to-html x env)) args)) (contains? HTML_TAGS name) (render-html-element name args env) (and (starts-with? name "~") (env-has? env name) (island? (env-get env name))) (render-html-island (env-get env name) args env) (starts-with? name "~") (let ((val (env-get env name))) (cond (component? val) (render-html-component val args env) (macro? val) (render-to-html (expand-macro val args env) env) :else (error (str "Unknown component: " name)))) (render-html-form? name) (dispatch-html-form name expr env) (and (env-has? env name) (macro? (env-get env name))) (render-to-html (expand-macro (env-get env name) args env) env) :else (render-value-to-html (trampoline (eval-expr expr env)) env)))))))) +(define + render-list-to-html + :effects (render) + (fn + ((expr :as list) (env :as dict)) + (if + (empty? expr) + "" + (let + ((head (first expr))) + (if + (not (= (type-of head) "symbol")) + (join "" (map (fn (x) (render-value-to-html x env)) expr)) + (let + ((name (symbol-name head)) (args (rest expr))) + (cond + (= name "<>") + (join "" (map (fn (x) (render-to-html x env)) args)) + (= name "raw!") + (join + "" + (map (fn (x) (str (trampoline (eval-expr x env)))) args)) + (= name "lake") + (render-html-lake args env) + (= name "marsh") + (render-html-marsh args env) + (or + (= name "portal") + (= name "error-boundary") + (= name "promise-delayed")) + (join "" (map (fn (x) (render-to-html x env)) args)) + (contains? HTML_TAGS name) + (render-html-element name args env) + (and + (starts-with? name "~") + (env-has? env name) + (island? (env-get env name))) + (render-html-island (env-get env name) args env) + (starts-with? name "~") + (let + ((val (env-get env name))) + (cond + (component? val) + (render-html-component val args env) + (macro? val) + (render-to-html (expand-macro val args env) env) + :else (error (str "Unknown component: " name)))) + (render-html-form? name) + (dispatch-html-form name expr env) + (and (env-has? env name) (macro? (env-get env name))) + (render-to-html (expand-macro (env-get env name) args env) env) + :else (render-value-to-html (trampoline (eval-expr expr env)) env)))))))) -(define dispatch-html-form :effects (render) (fn ((name :as string) (expr :as list) (env :as dict)) (cond (= name "if") (let ((cond-val (trampoline (eval-expr (nth expr 1) env)))) (if cond-val (render-to-html (nth expr 2) env) (if (> (len expr) 3) (render-to-html (nth expr 3) env) ""))) (= name "when") (if (not (trampoline (eval-expr (nth expr 1) env))) "" (if (= (len expr) 3) (render-to-html (nth expr 2) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range 2 (len expr)))))) (= name "cond") (let ((branch (eval-cond (rest expr) env))) (if branch (render-to-html branch env) "")) (= name "case") (render-to-html (trampoline (eval-expr expr env)) env) (= name "letrec") (let ((bindings (nth expr 1)) (body (slice expr 2)) (local (env-extend env))) (for-each (fn (pair) (let ((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair))))) (env-bind! local pname nil))) bindings) (for-each (fn (pair) (let ((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair))))) (env-set! local pname (trampoline (eval-expr (nth pair 1) local))))) bindings) (when (> (len body) 1) (for-each (fn (e) (trampoline (eval-expr e local))) (init body))) (render-to-html (last body) local)) (or (= name "let") (= name "let*")) (let ((local (process-bindings (nth expr 1) env))) (if (= (len expr) 3) (render-to-html (nth expr 2) local) (join "" (map (fn (i) (render-to-html (nth expr i) local)) (range 2 (len expr)))))) (or (= name "begin") (= name "do")) (if (= (len expr) 2) (render-to-html (nth expr 1) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range 1 (len expr))))) (definition-form? name) (do (trampoline (eval-expr expr env)) "") (= name "map") (let ((f (trampoline (eval-expr (nth expr 1) env))) (coll (trampoline (eval-expr (nth expr 2) env)))) (join "" (map (fn (item) (if (lambda? f) (render-lambda-html f (list item) env) (render-to-html (apply f (list item)) env))) coll))) (= name "map-indexed") (let ((f (trampoline (eval-expr (nth expr 1) env))) (coll (trampoline (eval-expr (nth expr 2) env)))) (join "" (map-indexed (fn (i item) (if (lambda? f) (render-lambda-html f (list i item) env) (render-to-html (apply f (list i item)) env))) coll))) (= name "filter") (render-to-html (trampoline (eval-expr expr env)) env) (= name "for-each") (let ((f (trampoline (eval-expr (nth expr 1) env))) (coll (trampoline (eval-expr (nth expr 2) env)))) (join "" (map (fn (item) (if (lambda? f) (render-lambda-html f (list item) env) (render-to-html (apply f (list item)) env))) coll))) (= name "scope") (let ((scope-name (trampoline (eval-expr (nth expr 1) env))) (rest-args (slice expr 2)) (scope-val nil) (body-exprs nil)) (if (and (>= (len rest-args) 2) (= (type-of (first rest-args)) "keyword") (= (keyword-name (first rest-args)) "value")) (do (set! scope-val (trampoline (eval-expr (nth rest-args 1) env))) (set! body-exprs (slice rest-args 2))) (set! body-exprs rest-args)) (scope-push! scope-name scope-val) (let ((result (if (= (len body-exprs) 1) (render-to-html (first body-exprs) env) (join "" (map (fn (e) (render-to-html e env)) body-exprs))))) (scope-pop! scope-name) result)) (= name "provide") (let ((prov-name (trampoline (eval-expr (nth expr 1) env))) (prov-val (trampoline (eval-expr (nth expr 2) env))) (body-start 3) (body-count (- (len expr) 3))) (scope-push! prov-name prov-val) (let ((result (if (= body-count 1) (render-to-html (nth expr body-start) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range body-start (+ body-start body-count))))))) (scope-pop! prov-name) result)) :else (render-value-to-html (trampoline (eval-expr expr env)) env)))) +(define + dispatch-html-form + :effects (render) + (fn + ((name :as string) (expr :as list) (env :as dict)) + (cond + (= name "if") + (let + ((cond-val (trampoline (eval-expr (nth expr 1) env)))) + (if + cond-val + (render-to-html (nth expr 2) env) + (if (> (len expr) 3) (render-to-html (nth expr 3) env) ""))) + (= name "when") + (if + (not (trampoline (eval-expr (nth expr 1) env))) + "" + (if + (= (len expr) 3) + (render-to-html (nth expr 2) env) + (join + "" + (map + (fn (i) (render-to-html (nth expr i) env)) + (range 2 (len expr)))))) + (= name "cond") + (let + ((branch (eval-cond (rest expr) env))) + (if branch (render-to-html branch env) "")) + (= name "case") + (render-to-html (trampoline (eval-expr expr env)) env) + (= name "letrec") + (let + ((bindings (nth expr 1)) + (body (slice expr 2)) + (local (env-extend env))) + (for-each + (fn + (pair) + (let + ((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair))))) + (env-bind! local pname nil))) + bindings) + (for-each + (fn + (pair) + (let + ((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair))))) + (env-set! + local + pname + (trampoline (eval-expr (nth pair 1) local))))) + bindings) + (when + (> (len body) 1) + (for-each (fn (e) (trampoline (eval-expr e local))) (init body))) + (render-to-html (last body) local)) + (or (= name "let") (= name "let*")) + (let + ((local (process-bindings (nth expr 1) env))) + (if + (= (len expr) 3) + (render-to-html (nth expr 2) local) + (join + "" + (map + (fn (i) (render-to-html (nth expr i) local)) + (range 2 (len expr)))))) + (or (= name "begin") (= name "do")) + (if + (= (len expr) 2) + (render-to-html (nth expr 1) env) + (join + "" + (map + (fn (i) (render-to-html (nth expr i) env)) + (range 1 (len expr))))) + (definition-form? name) + (do (trampoline (eval-expr expr env)) "") + (= name "map") + (let + ((f (trampoline (eval-expr (nth expr 1) env))) + (coll (trampoline (eval-expr (nth expr 2) env)))) + (join + "" + (map + (fn + (item) + (if + (lambda? f) + (render-lambda-html f (list item) env) + (render-to-html (apply f (list item)) env))) + coll))) + (= name "map-indexed") + (let + ((f (trampoline (eval-expr (nth expr 1) env))) + (coll (trampoline (eval-expr (nth expr 2) env)))) + (join + "" + (map-indexed + (fn + (i item) + (if + (lambda? f) + (render-lambda-html f (list i item) env) + (render-to-html (apply f (list i item)) env))) + coll))) + (= name "filter") + (render-to-html (trampoline (eval-expr expr env)) env) + (= name "for-each") + (let + ((f (trampoline (eval-expr (nth expr 1) env))) + (coll (trampoline (eval-expr (nth expr 2) env)))) + (join + "" + (map + (fn + (item) + (if + (lambda? f) + (render-lambda-html f (list item) env) + (render-to-html (apply f (list item)) env))) + coll))) + (= name "scope") + (let + ((scope-name (trampoline (eval-expr (nth expr 1) env))) + (rest-args (slice expr 2)) + (scope-val nil) + (body-exprs nil)) + (if + (and + (>= (len rest-args) 2) + (= (type-of (first rest-args)) "keyword") + (= (keyword-name (first rest-args)) "value")) + (do + (set! scope-val (trampoline (eval-expr (nth rest-args 1) env))) + (set! body-exprs (slice rest-args 2))) + (set! body-exprs rest-args)) + (scope-push! scope-name scope-val) + (let + ((result (if (= (len body-exprs) 1) (render-to-html (first body-exprs) env) (join "" (map (fn (e) (render-to-html e env)) body-exprs))))) + (scope-pop! scope-name) + result)) + (= name "provide") + (let + ((prov-name (trampoline (eval-expr (nth expr 1) env))) + (prov-val (trampoline (eval-expr (nth expr 2) env))) + (body-start 3) + (body-count (- (len expr) 3))) + (scope-push! prov-name prov-val) + (let + ((result (if (= body-count 1) (render-to-html (nth expr body-start) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range body-start (+ body-start body-count))))))) + (scope-pop! prov-name) + result)) + :else (render-value-to-html (trampoline (eval-expr expr env)) env)))) -(define render-lambda-html :effects (render) (fn ((f :as lambda) (args :as list) (env :as dict)) (let ((local (env-merge (lambda-closure f) env))) (for-each-indexed (fn (i p) (env-bind! local p (nth args i))) (lambda-params f)) (render-to-html (lambda-body f) local)))) +(define + render-lambda-html + :effects (render) + (fn + ((f :as lambda) (args :as list) (env :as dict)) + (let + ((local (env-merge (lambda-closure f) env))) + (for-each-indexed + (fn (i p) (env-bind! local p (nth args i))) + (lambda-params f)) + (render-to-html (lambda-body f) local)))) -(define render-html-component :effects (render) (fn ((comp :as component) (args :as list) (env :as dict)) (let ((kwargs (dict)) (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (dict-set! kwargs (keyword-name arg) val) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (let ((local (env-merge (component-closure comp) env))) (for-each (fn (p) (env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil))) (component-params comp)) (when (component-has-children? comp) (env-bind! local "children" (make-raw-html (join "" (map (fn (c) (render-to-html c env)) children))))) (render-to-html (component-body comp) local))))) +(define + render-html-component + :effects (render) + (fn + ((comp :as component) (args :as list) (env :as dict)) + (let + ((kwargs (dict)) (children (list))) + (reduce + (fn + (state arg) + (let + ((skip (get state "skip"))) + (if + skip + (assoc state "skip" false "i" (inc (get state "i"))) + (if + (and + (= (type-of arg) "keyword") + (< (inc (get state "i")) (len args))) + (let + ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) + (dict-set! kwargs (keyword-name arg) val) + (assoc state "skip" true "i" (inc (get state "i")))) + (do + (append! children arg) + (assoc state "i" (inc (get state "i")))))))) + (dict "i" 0 "skip" false) + args) + (let + ((local (env-merge (component-closure comp) env))) + (for-each + (fn + (p) + (env-bind! + local + p + (if (dict-has? kwargs p) (dict-get kwargs p) nil))) + (component-params comp)) + (when + (component-has-children? comp) + (env-bind! + local + "children" + (make-raw-html + (join "" (map (fn (c) (render-to-html c env)) children))))) + (render-to-html (component-body comp) local))))) -(define render-html-element :effects (render) (fn ((tag :as string) (args :as list) (env :as dict)) (let ((parsed (parse-element-args args env)) (attrs (first parsed)) (children (nth parsed 1)) (is-void (contains? VOID_ELEMENTS tag))) (if is-void (str "<" tag (render-attrs attrs) " />") (do (scope-push! "element-attrs" nil) (let ((content (join "" (map (fn (c) (render-to-html c env)) children)))) (for-each (fn (spread-dict) (merge-spread-attrs attrs spread-dict)) (scope-emitted "element-attrs")) (scope-pop! "element-attrs") (str "<" tag (render-attrs attrs) ">" content ""))))))) +(define + render-html-element + :effects (render) + (fn + ((tag :as string) (args :as list) (env :as dict)) + (let + ((parsed (parse-element-args args env)) + (attrs (first parsed)) + (children (nth parsed 1)) + (is-void (contains? VOID_ELEMENTS tag))) + (if + is-void + (str "<" tag (render-attrs attrs) " />") + (do + (scope-push! "element-attrs" nil) + (let + ((content (join "" (map (fn (c) (render-to-html c env)) children)))) + (for-each + (fn (spread-dict) (merge-spread-attrs attrs spread-dict)) + (scope-emitted "element-attrs")) + (scope-pop! "element-attrs") + (str "<" tag (render-attrs attrs) ">" content ""))))))) -(define render-html-lake :effects (render) (fn ((args :as list) (env :as dict)) (let ((lake-id nil) (lake-tag "div") (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((kname (keyword-name arg)) (kval (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (cond (= kname "id") (set! lake-id kval) (= kname "tag") (set! lake-tag kval)) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (let ((lake-attrs (dict "data-sx-lake" (or lake-id "")))) (scope-push! "element-attrs" nil) (let ((content (join "" (map (fn (c) (render-to-html c env)) children)))) (for-each (fn (spread-dict) (merge-spread-attrs lake-attrs spread-dict)) (scope-emitted "element-attrs")) (scope-pop! "element-attrs") (str "<" lake-tag (render-attrs lake-attrs) ">" content "")))))) +(define + render-html-lake + :effects (render) + (fn + ((args :as list) (env :as dict)) + (let + ((lake-id nil) (lake-tag "div") (children (list))) + (reduce + (fn + (state arg) + (let + ((skip (get state "skip"))) + (if + skip + (assoc state "skip" false "i" (inc (get state "i"))) + (if + (and + (= (type-of arg) "keyword") + (< (inc (get state "i")) (len args))) + (let + ((kname (keyword-name arg)) + (kval + (trampoline + (eval-expr (nth args (inc (get state "i"))) env)))) + (cond + (= kname "id") + (set! lake-id kval) + (= kname "tag") + (set! lake-tag kval)) + (assoc state "skip" true "i" (inc (get state "i")))) + (do + (append! children arg) + (assoc state "i" (inc (get state "i")))))))) + (dict "i" 0 "skip" false) + args) + (let + ((lake-attrs (dict "data-sx-lake" (or lake-id "")))) + (scope-push! "element-attrs" nil) + (let + ((content (join "" (map (fn (c) (render-to-html c env)) children)))) + (for-each + (fn (spread-dict) (merge-spread-attrs lake-attrs spread-dict)) + (scope-emitted "element-attrs")) + (scope-pop! "element-attrs") + (str + "<" + lake-tag + (render-attrs lake-attrs) + ">" + content + "")))))) -(define render-html-marsh :effects (render) (fn ((args :as list) (env :as dict)) (let ((marsh-id nil) (marsh-tag "div") (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((kname (keyword-name arg)) (kval (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (cond (= kname "id") (set! marsh-id kval) (= kname "tag") (set! marsh-tag kval) (= kname "transform") nil) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (let ((marsh-attrs (dict "data-sx-marsh" (or marsh-id "")))) (scope-push! "element-attrs" nil) (let ((content (join "" (map (fn (c) (render-to-html c env)) children)))) (for-each (fn (spread-dict) (merge-spread-attrs marsh-attrs spread-dict)) (scope-emitted "element-attrs")) (scope-pop! "element-attrs") (str "<" marsh-tag (render-attrs marsh-attrs) ">" content "")))))) +(define + render-html-marsh + :effects (render) + (fn + ((args :as list) (env :as dict)) + (let + ((marsh-id nil) (marsh-tag "div") (children (list))) + (reduce + (fn + (state arg) + (let + ((skip (get state "skip"))) + (if + skip + (assoc state "skip" false "i" (inc (get state "i"))) + (if + (and + (= (type-of arg) "keyword") + (< (inc (get state "i")) (len args))) + (let + ((kname (keyword-name arg)) + (kval + (trampoline + (eval-expr (nth args (inc (get state "i"))) env)))) + (cond + (= kname "id") + (set! marsh-id kval) + (= kname "tag") + (set! marsh-tag kval) + (= kname "transform") + nil) + (assoc state "skip" true "i" (inc (get state "i")))) + (do + (append! children arg) + (assoc state "i" (inc (get state "i")))))))) + (dict "i" 0 "skip" false) + args) + (let + ((marsh-attrs (dict "data-sx-marsh" (or marsh-id "")))) + (scope-push! "element-attrs" nil) + (let + ((content (join "" (map (fn (c) (render-to-html c env)) children)))) + (for-each + (fn (spread-dict) (merge-spread-attrs marsh-attrs spread-dict)) + (scope-emitted "element-attrs")) + (scope-pop! "element-attrs") + (str + "<" + marsh-tag + (render-attrs marsh-attrs) + ">" + content + "")))))) -(define render-html-island :effects (render) (fn ((island :as island) (args :as list) (env :as dict)) (let ((kwargs (dict)) (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (dict-set! kwargs (keyword-name arg) val) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (let ((local (env-merge (component-closure island) env)) (island-name (component-name island))) (for-each (fn (p) (env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil))) (component-params island)) (when (component-has-children? island) (env-bind! local "children" (make-raw-html (join "" (map (fn (c) (render-to-html c env)) children))))) (let ((body-html (cek-try (fn () (render-to-html (component-body island) local)) (fn (err) ""))) (state-sx (serialize-island-state kwargs))) (str "" body-html "")))))) +(define + render-html-island + :effects (render) + (fn + ((island :as island) (args :as list) (env :as dict)) + (let + ((kwargs (dict)) (children (list))) + (reduce + (fn + (state arg) + (let + ((skip (get state "skip"))) + (if + skip + (assoc state "skip" false "i" (inc (get state "i"))) + (if + (and + (= (type-of arg) "keyword") + (< (inc (get state "i")) (len args))) + (let + ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) + (dict-set! kwargs (keyword-name arg) val) + (assoc state "skip" true "i" (inc (get state "i")))) + (do + (append! children arg) + (assoc state "i" (inc (get state "i")))))))) + (dict "i" 0 "skip" false) + args) + (let + ((local (env-merge (component-closure island) env)) + (island-name (component-name island))) + (for-each + (fn + (p) + (env-bind! + local + p + (if (dict-has? kwargs p) (dict-get kwargs p) nil))) + (component-params island)) + (when + (component-has-children? island) + (env-bind! + local + "children" + (make-raw-html + (join "" (map (fn (c) (render-to-html c env)) children))))) + (let + ((body-html (cek-try (fn () (render-to-html (component-body island) local)) (fn (err) ""))) + (state-sx (serialize-island-state kwargs))) + (str + "" + body-html + "")))))) -(define serialize-island-state :effects () (fn ((kwargs :as dict)) (if (empty-dict? kwargs) nil (sx-serialize kwargs)))) +(define + serialize-island-state + :effects () + (fn + ((kwargs :as dict)) + (if (empty-dict? kwargs) nil (sx-serialize kwargs))))