diff --git a/hosts/javascript/bootstrap.py b/hosts/javascript/bootstrap.py index 8bf4b7c..5206da4 100644 --- a/hosts/javascript/bootstrap.py +++ b/hosts/javascript/bootstrap.py @@ -131,6 +131,8 @@ def compile_ref_to_js( # evaluator.sx = merged frames + eval utilities + CEK machine sx_files = [ ("evaluator.sx", "evaluator (frames + eval + CEK)"), + ("freeze.sx", "freeze (serializable state boundaries)"), + ("content.sx", "content (content-addressed computation)"), ("render.sx", "render (core)"), ] for name in ("parser", "html", "sx", "dom", "engine", "orchestration", "boot"): diff --git a/hosts/javascript/platform.py b/hosts/javascript/platform.py index c87cfab..9cb9750 100644 --- a/hosts/javascript/platform.py +++ b/hosts/javascript/platform.py @@ -13,7 +13,14 @@ from shared.sx.types import Symbol def extract_defines(source: str) -> list[tuple[str, list]]: - """Parse .sx source, return list of (name, define-expr) for top-level defines.""" + """Parse .sx source, return list of (name, expr) for top-level forms. + + Extracts (define name ...) forms with their name, plus selected + non-define top-level expressions (e.g. register-special-form! calls) + with a synthetic name for the comment. + """ + # Top-level calls that should be transpiled (not special forms) + _TOPLEVEL_CALLS = {"register-special-form!"} exprs = parse_all(source) defines = [] for expr in exprs: @@ -21,6 +28,10 @@ def extract_defines(source: str) -> list[tuple[str, list]]: if expr[0].name == "define": name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1]) defines.append((name, expr)) + elif expr[0].name in _TOPLEVEL_CALLS: + # Top-level call expression (e.g. register-special-form!) + call_name = expr[0].name + defines.append((f"({call_name} ...)", expr)) return defines ADAPTER_FILES = { @@ -283,9 +294,11 @@ ASYNC_IO_JS = ''' if (hname === "map-indexed") return asyncRenderMapIndexed(expr, env, ns); if (hname === "for-each") return asyncRenderMap(expr, env, ns); - // define/defcomp/defmacro — eval for side effects + // define/defcomp/defmacro and custom special forms — eval for side effects if (hname === "define" || hname === "defcomp" || hname === "defmacro" || - hname === "defstyle" || hname === "defhandler") { + hname === "defstyle" || hname === "defhandler" || + hname === "deftype" || hname === "defeffect" || + (typeof _customSpecialForms !== "undefined" && _customSpecialForms[hname])) { trampoline(evalExpr(expr, env)); return null; } @@ -1412,10 +1425,7 @@ PLATFORM_JS_POST = ''' var dict_fn = PRIMITIVES["dict"]; // HTML rendering helpers - function escapeHtml(s) { - return String(s).replace(/&/g,"&").replace(//g,">").replace(/"/g,"""); - } - function escapeAttr(s) { return escapeHtml(s); } + // escape-html and escape-attr are now library functions defined in render.sx function rawHtmlContent(r) { return r.html; } function makeRawHtml(s) { return { _raw: true, html: s }; } function sxExprSource(x) { return x && x.source ? x.source : String(x); } @@ -1429,7 +1439,8 @@ PLATFORM_JS_POST = ''' function isDefinitionForm(name) { return name === "define" || name === "defcomp" || name === "defmacro" || - name === "defstyle" || name === "defhandler"; + name === "defstyle" || name === "defhandler" || + name === "deftype" || name === "defeffect"; } function indexOf_(s, ch) { @@ -1703,6 +1714,11 @@ PLATFORM_DOM_JS = """ _renderExprFn = function(expr, env) { return renderToDom(expr, env, null); }; _renderMode = true; // Browser always evaluates in render context. + // Wire CEK render hooks — evaluator checks _renderCheck/_renderFn instead of + // the old renderActiveP()/isRenderExpr()/renderExpr() triple. + _renderCheck = function(expr, env) { return isRenderExpr(expr); }; + _renderFn = function(expr, env) { return renderToDom(expr, env, null); }; + var SVG_NS = "http://www.w3.org/2000/svg"; var MATH_NS = "http://www.w3.org/1998/Math/MathML"; diff --git a/hosts/javascript/transpiler.sx b/hosts/javascript/transpiler.sx index aecf918..3c8764d 100644 --- a/hosts/javascript/transpiler.sx +++ b/hosts/javascript/transpiler.sx @@ -93,6 +93,11 @@ "dispose-computed" "disposeComputed" "with-island-scope" "withIslandScope" "register-in-scope" "registerInScope" + "*custom-special-forms*" "_customSpecialForms" + "register-special-form!" "registerSpecialForm" + "*render-check*" "_renderCheck" + "*render-fn*" "_renderFn" + "is-else-clause?" "isElseClause" "*batch-depth*" "_batchDepth" "*batch-queue*" "_batchQueue" "*store-registry*" "_storeRegistry" @@ -181,7 +186,6 @@ "ho-some" "hoSome" "ho-every" "hoEvery" "ho-for-each" "hoForEach" - "sf-defstyle" "sfDefstyle" "kf-name" "kfName" "special-form?" "isSpecialForm" "ho-form?" "isHoForm" diff --git a/hosts/ocaml/bootstrap.py b/hosts/ocaml/bootstrap.py index 89d5bbf..c65968a 100644 --- a/hosts/ocaml/bootstrap.py +++ b/hosts/ocaml/bootstrap.py @@ -43,16 +43,30 @@ PREAMBLE = """\ open Sx_types open Sx_runtime -(* Trampoline — evaluates thunks via the CEK machine. - eval_expr is defined in the transpiled block below. *) -let trampoline v = v (* CEK machine doesn't produce thunks *) +(* Trampoline — forward ref, resolved after eval_expr is defined. *) +let trampoline_fn : (value -> value) ref = ref (fun v -> v) +let trampoline v = !trampoline_fn v + + + +(* === Mutable state for strict mode === *) +(* These are defined as top-level refs because the transpiler cannot handle + global set! mutation (it creates local refs that shadow the global). *) +let _strict_ref = ref (Bool false) +let _prim_param_types_ref = ref Nil """ -# OCaml fixups — override iterative CEK run +# OCaml fixups — wire up trampoline + iterative CEK run FIXUPS = """\ +(* Wire up trampoline to resolve thunks via the CEK machine *) +let () = trampoline_fn := (fun v -> + match v with + | Thunk (expr, env) -> eval_expr expr (Env env) + | _ -> v) + (* Override recursive cek_run with iterative loop *) let cek_run_iterative state = let s = ref state in @@ -122,7 +136,63 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str: parts.append(result) parts.append(FIXUPS) - return "\n".join(parts) + output = "\n".join(parts) + + # Post-process: fix mutable globals that the transpiler can't handle. + # The transpiler emits local refs for set! targets within functions, + # but top-level globals (*strict*, *prim-param-types*) need to use + # the pre-declared refs from the preamble. + import re + + # Fix *strict*: use _strict_ref instead of immutable let rec binding + output = re.sub( + r'and _strict_ =\n \(Bool false\)', + 'and _strict_ = !_strict_ref', + output, + ) + # Fix set-strict!: use _strict_ref instead of local ref + output = re.sub( + r'and set_strict_b val\' =\n let _strict_ = ref Nil in \(_strict_ := val\'; Nil\)', + "and set_strict_b val' =\n _strict_ref := val'; Nil", + output, + ) + # Fix *prim-param-types*: use _prim_param_types_ref + output = re.sub( + r'and _prim_param_types_ =\n Nil', + 'and _prim_param_types_ = !_prim_param_types_ref', + output, + ) + # Fix set-prim-param-types!: use _prim_param_types_ref + output = re.sub( + r'and set_prim_param_types_b types =\n let _prim_param_types_ = ref Nil in \(_prim_param_types_ := types; Nil\)', + "and set_prim_param_types_b types =\n _prim_param_types_ref := types; Nil", + output, + ) + + # Fix all runtime reads of _strict_ and _prim_param_types_ to deref + # the mutable refs instead of using the stale let-rec bindings. + # This is needed because let-rec value bindings capture initial values. + # Use regex with word boundary to avoid replacing _strict_ref with + # !_strict_refref. + def fix_mutable_reads(text): + lines = text.split('\n') + fixed = [] + for line in lines: + # Skip the definition lines + stripped = line.strip() + if stripped.startswith('and _strict_ =') or stripped.startswith('and _prim_param_types_ ='): + fixed.append(line) + continue + # Replace _strict_ as a standalone identifier only (not inside + # other names like set_strict_b). Match when preceded by space, + # paren, or start-of-line, and followed by space, paren, or ;. + line = re.sub(r'(?<=[ (])_strict_(?=[ );])', '!_strict_ref', line) + line = re.sub(r'(?<=[ (])_prim_param_types_(?=[ );])', '!_prim_param_types_ref', line) + fixed.append(line) + return '\n'.join(fixed) + output = fix_mutable_reads(output) + + return output def main(): diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index ba26d3e..d3fb8d1 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -13,9 +13,13 @@ let trampoline v = !trampoline_fn v (* === Mutable state for strict mode === *) +(* These are defined as top-level refs because the transpiler cannot handle + global set! mutation (it creates local refs that shadow the global). *) let _strict_ref = ref (Bool false) let _prim_param_types_ref = ref Nil + + (* === Transpiled from evaluator (frames + eval + CEK) === *) (* make-cek-state *) @@ -206,14 +210,30 @@ and has_reactive_reset_frame_p kont = and kont_capture_to_reactive_reset kont = (let rec scan = (fun k captured -> (if sx_truthy ((empty_p (k))) then (raise (Eval_error (value_to_str (String "reactive deref without enclosing reactive-reset")))) else (let frame = (first (k)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "reactive-reset")])) then (List [captured; frame; (rest (k))]) else (scan ((rest (k))) ((prim_call "append" [captured; (List [frame])]))))))) in (scan (kont) ((List [])))) -(* *strict* — reads from mutable ref each time *) +(* *custom-special-forms* *) +and custom_special_forms = + (Dict (Hashtbl.create 0)) + +(* register-special-form! *) +and register_special_form name handler = + (sx_dict_set_b custom_special_forms name handler) + +(* *render-check* *) +and render_check = + Nil + +(* *render-fn* *) +and render_fn = + Nil + +(* *strict* *) and _strict_ = !_strict_ref (* set-strict! *) and set_strict_b val' = _strict_ref := val'; Nil -(* *prim-param-types* — reads from mutable ref *) +(* *prim-param-types* *) and _prim_param_types_ = !_prim_param_types_ref (* set-prim-param-types! *) @@ -244,6 +264,10 @@ and parse_keyword_args raw_args env = and cond_scheme_p clauses = (Bool (List.for_all (fun c -> sx_truthy ((let _and = (prim_call "=" [(type_of (c)); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len (c)); (Number 2.0)])))) (sx_to_list clauses))) +(* is-else-clause? *) +and is_else_clause test = + (let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (let _and = (prim_call "=" [(type_of (test)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _or = (prim_call "=" [(symbol_name (test)); (String "else")]) in if sx_truthy _or then _or else (prim_call "=" [(symbol_name (test)); (String ":else")])))) + (* sf-named-let *) and sf_named_let args env = (let loop_name = (symbol_name ((first (args)))) in let bindings = (nth (args) ((Number 1.0))) in let body = (prim_call "slice" [args; (Number 2.0)]) in let params = ref ((List [])) in let inits = ref ((List [])) in (let () = ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (List.iter (fun binding -> ignore ((let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))); Nil)) in (inits := sx_append_b !inits (nth (binding) ((Number 1.0))); Nil)))) (sx_to_list bindings); Nil) else (List.fold_left (fun _acc pair_idx -> (let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))); (String "symbol")])) then (symbol_name ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))) else (nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)])))); Nil)) in (inits := sx_append_b !inits (nth (bindings) ((prim_call "inc" [(prim_call "*" [pair_idx; (Number 2.0)])]))); Nil))) Nil (sx_to_list (prim_call "range" [(Number 0.0); (prim_call "/" [(len (bindings)); (Number 2.0)])]))))) in (let loop_body = (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (first (body)) else (cons ((make_symbol ((String "begin")))) (body))) in let loop_fn = (make_lambda (!params) (loop_body) (env)) in (let () = ignore ((set_lambda_name loop_fn (sx_to_string loop_name))) in (let () = ignore ((env_bind (lambda_closure (loop_fn)) (sx_to_string loop_name) loop_fn)) in (let init_vals = (List (List.map (fun e -> (trampoline ((eval_expr (e) (env))))) (sx_to_list !inits))) in (call_lambda (loop_fn) (init_vals) (env)))))))) @@ -276,26 +300,6 @@ and sf_defmacro args env = and parse_macro_params params_expr = (let params = ref ((List [])) in let rest_param = ref (Nil) in (let () = ignore ((List.fold_left (fun state p -> (if sx_truthy ((let _and = (prim_call "=" [(type_of (p)); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (p)); (String "&rest")]))) then (prim_call "assoc" [state; (String "in-rest"); (Bool true)]) else (if sx_truthy ((get (state) ((String "in-rest")))) then (let () = ignore ((rest_param := (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else p); Nil)) in state) else (let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else p); Nil)) in state)))) (let _d = Hashtbl.create 1 in Hashtbl.replace _d (value_to_str (String "in-rest")) (Bool false); Dict _d) (sx_to_list params_expr))) in (List [!params; !rest_param]))) -(* sf-defstyle *) -and sf_defstyle args env = - (let name_sym = (first (args)) in let value = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) value)) in value)) - -(* make-type-def *) -and make_type_def name params body = - (let _d = Hashtbl.create 3 in Hashtbl.replace _d "name" name; Hashtbl.replace _d "params" params; Hashtbl.replace _d "body" body; Dict _d) - -(* normalize-type-body *) -and normalize_type_body body = - (if sx_truthy ((is_nil (body))) then (String "nil") else (if sx_truthy ((prim_call "=" [(type_of (body)); (String "symbol")])) then (symbol_name (body)) else (if sx_truthy ((prim_call "=" [(type_of (body)); (String "string")])) then body else (if sx_truthy ((prim_call "=" [(type_of (body)); (String "keyword")])) then (keyword_name (body)) else (if sx_truthy ((prim_call "=" [(type_of (body)); (String "dict")])) then (match body with Dict _tbl -> let _r = Hashtbl.create (Hashtbl.length _tbl) in Hashtbl.iter (fun k v -> let k = String k in Hashtbl.replace _r (value_to_str k) ((normalize_type_body (v)))) _tbl; Dict _r | _ -> raise (Eval_error "map-dict: expected dict")) else (if sx_truthy ((prim_call "=" [(type_of (body)); (String "list")])) then (if sx_truthy ((empty_p (body))) then (String "any") else (let head = (first (body)) in (let head_name = (if sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])) then (symbol_name (head)) else (String (sx_str [head]))) in (if sx_truthy ((prim_call "=" [head_name; (String "union")])) then (cons ((String "or")) ((List (List.map (fun _x -> normalize_type_body _x) (sx_to_list (rest (body))))))) else (cons (head_name) ((List (List.map (fun _x -> normalize_type_body _x) (sx_to_list (rest (body))))))))))) else (String (sx_str [body])))))))) - -(* sf-deftype *) -and sf_deftype args env = - (let name_or_form = (first (args)) in let body_expr = (nth (args) ((Number 1.0))) in let type_name = ref (Nil) in let type_params = ref ((List [])) in (let () = ignore ((if sx_truthy ((prim_call "=" [(type_of (name_or_form)); (String "symbol")])) then (type_name := (symbol_name (name_or_form)); Nil) else (if sx_truthy ((prim_call "=" [(type_of (name_or_form)); (String "list")])) then (let () = ignore ((type_name := (symbol_name ((first (name_or_form)))); Nil)) in (type_params := (List (List.map (fun p -> (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else (String (sx_str [p])))) (sx_to_list (rest (name_or_form))))); Nil)) else Nil))) in (let body = (normalize_type_body (body_expr)) in let registry = (if sx_truthy ((env_has (env) ((String "*type-registry*")))) then (env_get (env) ((String "*type-registry*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b registry !type_name (make_type_def (!type_name) (!type_params) (body)))) in (let () = ignore ((env_bind env (sx_to_string (String "*type-registry*")) registry)) in Nil))))) - -(* sf-defeffect *) -and sf_defeffect args env = - (let effect_name = (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (symbol_name ((first (args)))) else (String (sx_str [(first (args))]))) in let registry = ref ((if sx_truthy ((env_has (env) ((String "*effect-registry*")))) then (env_get (env) ((String "*effect-registry*"))) else (List []))) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!registry; effect_name])))))) then (registry := sx_append_b !registry effect_name; Nil) else Nil)) in (let () = ignore ((env_bind env (sx_to_string (String "*effect-registry*")) !registry)) in Nil))) - (* qq-expand *) and qq_expand template env = (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (template)); (String "list")])))))) then template else (if sx_truthy ((empty_p (template))) then (List []) else (let head = (first (template)) in (if sx_truthy ((let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (head)); (String "unquote")]))) then (trampoline ((eval_expr ((nth (template) ((Number 1.0)))) (env)))) else (List.fold_left (fun result' item -> (if sx_truthy ((let _and = (prim_call "=" [(type_of (item)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (item)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (item)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (item)))); (String "splice-unquote")]))))) then (let spliced = (trampoline ((eval_expr ((nth (item) ((Number 1.0)))) (env)))) in (if sx_truthy ((prim_call "=" [(type_of (spliced)); (String "list")])) then (prim_call "concat" [result'; spliced]) else (if sx_truthy ((is_nil (spliced))) then result' else (prim_call "concat" [result'; (List [spliced])])))) else (prim_call "concat" [result'; (List [(qq_expand (item) (env))])]))) (List []) (sx_to_list template)))))) @@ -334,7 +338,7 @@ 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 (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 "defstyle")])) then (make_cek_value ((sf_defstyle (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defhandler")])) then (make_cek_value ((sf_defhandler (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defpage")])) then (make_cek_value ((sf_defpage (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defquery")])) then (make_cek_value ((sf_defquery (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defaction")])) then (make_cek_value ((sf_defaction (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "deftype")])) then (make_cek_value ((sf_deftype (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defeffect")])) then (make_cek_value ((sf_defeffect (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 (make_cek_value ((sf_letrec (args) (env))) (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 ((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_active_p ()) in if not (sx_truthy _and) then _and else (is_render_expr (expr)))) then (make_cek_value ((render_expr (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 (make_cek_value ((sf_letrec (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "reset")])) then (step_sf_reset (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "shift")])) then (step_sf_shift (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "deref")])) then (step_sf_deref (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "scope")])) then (step_sf_scope (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "provide")])) then (step_sf_provide (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "dynamic-wind")])) then (make_cek_value ((sf_dynamic_wind (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "map")])) then (step_ho_map (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "map-indexed")])) then (step_ho_map_indexed (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "filter")])) then (step_ho_filter (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "reduce")])) then (step_ho_reduce (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "some")])) then (step_ho_some (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "every?")])) then (step_ho_every (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "for-each")])) then (step_ho_for_each (args) (env) (kont)) else (if sx_truthy ((prim_call "has-key?" [custom_special_forms; name])) then (make_cek_value ((cek_call ((get (custom_special_forms) (name))) (List [args; env]))) (env) (kont)) else (if sx_truthy ((let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_macro ((env_get (env) (name)))))) then (let mac = (env_get (env) (name)) in (make_cek_state ((expand_macro (mac) (args) (env))) (env) (kont))) else (if sx_truthy ((let _and = render_check in if not (sx_truthy _and) then _and else (cek_call (render_check) (List [expr; env])))) then (make_cek_value ((cek_call (render_fn) (List [expr; env]))) (env) (kont)) else (step_eval_call (head) (args) (env) (kont))))))))))))))))))))))))))))))))))))))))))) else (step_eval_call (head) (args) (env) (kont))))) (* step-sf-if *) and step_sf_if args env kont = @@ -370,7 +374,7 @@ and step_sf_or args env kont = (* step-sf-cond *) and step_sf_cond args env kont = - (let scheme_p = (cond_scheme_p (args)) in (if sx_truthy (scheme_p) then (if sx_truthy ((empty_p (args))) then (make_cek_value (Nil) (env) (kont)) else (let clause = (first (args)) in let test = (first (clause)) in (if sx_truthy ((let _or = (let _and = (prim_call "=" [(type_of (test)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _or = (prim_call "=" [(symbol_name (test)); (String "else")]) in if sx_truthy _or then _or else (prim_call "=" [(symbol_name (test)); (String ":else")]))) in if sx_truthy _or then _or else (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])))) then (make_cek_state ((nth (clause) ((Number 1.0)))) (env) (kont)) else (make_cek_state (test) (env) ((kont_push ((make_cond_frame (args) (env) ((Bool true)))) (kont))))))) else (if sx_truthy ((prim_call "<" [(len (args)); (Number 2.0)])) then (make_cek_value (Nil) (env) (kont)) else (let test = (first (args)) in (if sx_truthy ((let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (let _and = (prim_call "=" [(type_of (test)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _or = (prim_call "=" [(symbol_name (test)); (String "else")]) in if sx_truthy _or then _or else (prim_call "=" [(symbol_name (test)); (String ":else")]))))) then (make_cek_state ((nth (args) ((Number 1.0)))) (env) (kont)) else (make_cek_state (test) (env) ((kont_push ((make_cond_frame (args) (env) ((Bool false)))) (kont))))))))) + (let scheme_p = (cond_scheme_p (args)) in (if sx_truthy (scheme_p) then (if sx_truthy ((empty_p (args))) then (make_cek_value (Nil) (env) (kont)) else (let clause = (first (args)) in let test = (first (clause)) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state ((nth (clause) ((Number 1.0)))) (env) (kont)) else (make_cek_state (test) (env) ((kont_push ((make_cond_frame (args) (env) ((Bool true)))) (kont))))))) else (if sx_truthy ((prim_call "<" [(len (args)); (Number 2.0)])) then (make_cek_value (Nil) (env) (kont)) else (let test = (first (args)) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state ((nth (args) ((Number 1.0)))) (env) (kont)) else (make_cek_state (test) (env) ((kont_push ((make_cond_frame (args) (env) ((Bool false)))) (kont))))))))) (* step-sf-case *) and step_sf_case args env kont = @@ -474,7 +478,7 @@ 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 ((let _or = (let _and = (prim_call "=" [(type_of (next_test)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _or = (prim_call "=" [(symbol_name (next_test)); (String "else")]) in if sx_truthy _or then _or else (prim_call "=" [(symbol_name (next_test)); (String ":else")]))) in if sx_truthy _or then _or else (let _and = (prim_call "=" [(type_of (next_test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (next_test)); (String "else")])))) 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 ((let _or = (let _and = (prim_call "=" [(type_of (next_test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (next_test)); (String "else")])) in if sx_truthy _or then _or else (let _and = (prim_call "=" [(type_of (next_test)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _or = (prim_call "=" [(symbol_name (next_test)); (String "else")]) in if sx_truthy _or then _or else (prim_call "=" [(symbol_name (next_test)); (String ":else")]))))) then (make_cek_state ((nth (next) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next) (fenv) ((Bool false)))) (rest_k))))))))))) else (if sx_truthy ((prim_call "=" [ft; (String "case")])) then (let match_val = (get (frame) ((String "match-val"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (match_val))) then (sf_case_step_loop (value) (remaining) (fenv) (rest_k)) else (sf_case_step_loop (match_val) (remaining) (fenv) (rest_k)))) else (if sx_truthy ((prim_call "=" [ft; (String "thread")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (let form = (first (remaining)) in let rest_forms = (rest (remaining)) in let new_kont = (if sx_truthy ((empty_p ((rest (remaining))))) then rest_k else (kont_push ((make_thread_frame ((rest (remaining))) (fenv))) (rest_k))) in (if sx_truthy ((let _and = (prim_call "=" [(type_of (form)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (form)))))) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (form)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (ho_form_name_p ((symbol_name ((first (form)))))))))) then (make_cek_state ((cons ((first (form))) ((cons ((List [(Symbol "quote"); value])) ((rest (form))))))) (fenv) (new_kont)) else (let result' = (if sx_truthy ((prim_call "=" [(type_of (form)); (String "list")])) then (let f = (trampoline ((eval_expr ((first (form))) (fenv)))) in let rargs = (List (List.map (fun a -> (trampoline ((eval_expr (a) (fenv))))) (sx_to_list (rest (form))))) in let all_args = (cons (value) (rargs)) in (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_lambda (f)))))))) then (sx_apply f all_args) else (if sx_truthy ((is_lambda (f))) then (trampoline ((call_lambda (f) (all_args) (fenv)))) else (raise (Eval_error (value_to_str (String (sx_str [(String "-> form not callable: "); (inspect (f))])))))))) else (let f = (trampoline ((eval_expr (form) (fenv)))) in (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_lambda (f)))))))) then (cek_call (f) (List [value])) else (if sx_truthy ((is_lambda (f))) then (trampoline ((call_lambda (f) ((List [value])) (fenv)))) else (raise (Eval_error (value_to_str (String (sx_str [(String "-> form not callable: "); (inspect (f))]))))))))) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv))) (rest_k)))))))))) else (if sx_truthy ((prim_call "=" [ft; (String "arg")])) then (let f = (get (frame) ((String "f"))) in let evaled = (get (frame) ((String "evaled"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let raw_args = (get (frame) ((String "raw-args"))) in let hname = (get (frame) ((String "head-name"))) in (if sx_truthy ((is_nil (f))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) ((List []))) else Nil)) in (if sx_truthy ((empty_p (remaining))) then (continue_with_call (value) ((List [])) (fenv) (raw_args) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (value) ((List [])) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))) else (let new_evaled = (prim_call "append" [evaled; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) (new_evaled)) else Nil)) in (continue_with_call (f) (new_evaled) (fenv) (raw_args) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (f) (new_evaled) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "dict")])) then (let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let fenv = (get (frame) ((String "env"))) in (let last_result = (last (results)) in let completed = (prim_call "append" [(prim_call "slice" [results; (Number 0.0); (prim_call "dec" [(len (results))])]); (List [(List [(first (last_result)); value])])]) in (if sx_truthy ((empty_p (remaining))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun pair -> ignore ((sx_dict_set_b d (first (pair)) (nth (pair) ((Number 1.0)))))) (sx_to_list completed); Nil)) in (make_cek_value (d) (fenv) (rest_k)))) else (let next_entry = (first (remaining)) in (make_cek_state ((nth (next_entry) ((Number 1.0)))) (fenv) ((kont_push ((make_dict_frame ((rest (remaining))) ((prim_call "append" [completed; (List [(List [(first (next_entry))])])])) (fenv))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "ho-setup")])) then (let ho_type = (get (frame) ((String "ho-type"))) in let remaining = (get (frame) ((String "remaining"))) in let evaled = (prim_call "append" [(get (frame) ((String "evaled"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (ho_setup_dispatch (ho_type) (evaled) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_ho_setup_frame (ho_type) ((rest (remaining))) (evaled) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "reset")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [ft; (String "deref")])) then (let val' = value in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy ((is_signal (val'))))))) then (make_cek_value (val') (fenv) (rest_k)) else (if sx_truthy ((has_reactive_reset_frame_p (rest_k))) then (reactive_shift_deref (val') (fenv) (rest_k)) else (let () = ignore ((let ctx = (sx_context ((String "sx-reactive")) (Nil)) in (if sx_truthy (ctx) then (let dep_list = ref ((get (ctx) ((String "deps")))) in let notify_fn = (get (ctx) ((String "notify"))) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!dep_list; val'])))))) then (let () = ignore ((dep_list := sx_append_b !dep_list val'; Nil)) in (signal_add_sub_b (val') (notify_fn))) else Nil)) else Nil))) in (make_cek_value ((signal_value (val'))) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "reactive-reset")])) then (let update_fn = (get (frame) ((String "update-fn"))) in let first_p = (get (frame) ((String "first-render"))) in (let () = ignore ((if sx_truthy ((let _and = update_fn in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (first_p)))))) then (cek_call (update_fn) ((List [value]))) else Nil)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [ft; (String "scope")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop (name))) in (make_cek_value (value) (fenv) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_scope_frame (name) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "provide")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "scope-acc")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((let new_frame = (make_scope_acc_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "emitted") (get (frame) ((String "emitted"))))) in new_frame))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let indexed = (get (frame) ((String "indexed"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (prim_call "append" [results; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let call_args = (if sx_truthy (indexed) then (List [(len (new_results)); (first (remaining))]) else (List [(first (remaining))])) in let next_frame = (if sx_truthy (indexed) then (make_map_indexed_frame (f) ((rest (remaining))) (new_results) (fenv)) else (make_map_frame (f) ((rest (remaining))) (new_results) (fenv))) in (continue_with_call (f) (call_args) (fenv) ((List [])) ((kont_push (next_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "filter")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let current_item = (get (frame) ((String "current-item"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (if sx_truthy (value) then (prim_call "append" [results; (List [current_item])]) else results) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (remaining))) (new_results) ((first (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [ft; (String "reduce")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (continue_with_call (f) ((List [value; (first (remaining))])) (fenv) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "for-each")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (Nil) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "some")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy (value) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_some_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [ft; (String "every")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool true)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_every_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown frame type: "); ft])))))))))))))))))))))))))))))))))) + (let value = (cek_value (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (if sx_truthy ((kont_empty_p (kont))) then state else (let frame = (kont_top (kont)) in let rest_k = (kont_pop (kont)) in let ft = (frame_type (frame)) in (if sx_truthy ((prim_call "=" [ft; (String "if")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (make_cek_state ((get (frame) ((String "then")))) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((is_nil ((get (frame) ((String "else")))))) then (make_cek_value (Nil) (env) (rest_k)) else (make_cek_state ((get (frame) ((String "else")))) ((get (frame) ((String "env")))) (rest_k)))) else (if sx_truthy ((prim_call "=" [ft; (String "when")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (make_cek_state ((first (body))) (fenv) (rest_k)) else (make_cek_state ((first (body))) (fenv) ((kont_push ((make_begin_frame ((rest (body))) (fenv))) (rest_k))))))) else (make_cek_value (Nil) (env) (rest_k))) else (if sx_truthy ((prim_call "=" [ft; (String "begin")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then (make_cek_state ((first (remaining))) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_begin_frame ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [ft; (String "let")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let body = (get (frame) ((String "body"))) in let local = (get (frame) ((String "env"))) in (let () = ignore ((env_bind local (sx_to_string name) value)) in (if sx_truthy ((empty_p (remaining))) then (step_sf_begin (body) (local) (rest_k)) else (let next_binding = (first (remaining)) in let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (next_binding)))); (String "symbol")])) then (symbol_name ((first (next_binding)))) else (first (next_binding))) in (make_cek_state ((nth (next_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) ((rest (remaining))) (body) (local))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "define")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let has_effects = (get (frame) ((String "has-effects"))) in let effect_list = (get (frame) ((String "effect-list"))) in (let () = ignore ((if sx_truthy ((let _and = (is_lambda (value)) in if not (sx_truthy _and) then _and else (is_nil ((lambda_name (value)))))) then (set_lambda_name value (sx_to_string name)) else Nil)) in (let () = ignore ((env_bind fenv (sx_to_string name) value)) in (let () = ignore ((if sx_truthy (has_effects) then (let effect_names = (if sx_truthy ((prim_call "=" [(type_of (effect_list)); (String "list")])) then (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else (String (sx_str [e])))) (sx_to_list effect_list))) else (List [(String (sx_str [effect_list]))])) in let effect_anns = (if sx_truthy ((env_has (fenv) ((String "*effect-annotations*")))) then (env_get (fenv) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns name effect_names)) in (env_bind fenv (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (make_cek_value (value) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((env_set fenv (sx_to_string name) value)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [ft; (String "and")])) then (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_and_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "or")])) then (if sx_truthy (value) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_or_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "cond")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let scheme_p = (get (frame) ((String "scheme"))) in (if sx_truthy (scheme_p) then (if sx_truthy (value) then (make_cek_state ((nth ((first (remaining))) ((Number 1.0)))) (fenv) (rest_k)) else (let next_clauses = (rest (remaining)) in (if sx_truthy ((empty_p (next_clauses))) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_clause = (first (next_clauses)) in let next_test = (first (next_clause)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next_clause) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next_clauses) (fenv) ((Bool true)))) (rest_k))))))))) else (if sx_truthy (value) then (make_cek_state ((nth (remaining) ((Number 1.0)))) (fenv) (rest_k)) else (let next = (prim_call "slice" [remaining; (Number 2.0)]) in (if sx_truthy ((prim_call "<" [(len (next)); (Number 2.0)])) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_test = (first (next)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next) (fenv) ((Bool false)))) (rest_k))))))))))) else (if sx_truthy ((prim_call "=" [ft; (String "case")])) then (let match_val = (get (frame) ((String "match-val"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (match_val))) then (sf_case_step_loop (value) (remaining) (fenv) (rest_k)) else (sf_case_step_loop (match_val) (remaining) (fenv) (rest_k)))) else (if sx_truthy ((prim_call "=" [ft; (String "thread")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (let form = (first (remaining)) in let rest_forms = (rest (remaining)) in let new_kont = (if sx_truthy ((empty_p ((rest (remaining))))) then rest_k else (kont_push ((make_thread_frame ((rest (remaining))) (fenv))) (rest_k))) in (if sx_truthy ((let _and = (prim_call "=" [(type_of (form)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (form)))))) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (form)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (ho_form_name_p ((symbol_name ((first (form)))))))))) then (make_cek_state ((cons ((first (form))) ((cons ((List [(Symbol "quote"); value])) ((rest (form))))))) (fenv) (new_kont)) else (let result' = (if sx_truthy ((prim_call "=" [(type_of (form)); (String "list")])) then (let f = (trampoline ((eval_expr ((first (form))) (fenv)))) in let rargs = (List (List.map (fun a -> (trampoline ((eval_expr (a) (fenv))))) (sx_to_list (rest (form))))) in let all_args = (cons (value) (rargs)) in (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_lambda (f)))))))) then (sx_apply f all_args) else (if sx_truthy ((is_lambda (f))) then (trampoline ((call_lambda (f) (all_args) (fenv)))) else (raise (Eval_error (value_to_str (String (sx_str [(String "-> form not callable: "); (inspect (f))])))))))) else (let f = (trampoline ((eval_expr (form) (fenv)))) in (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_lambda (f)))))))) then (cek_call (f) (List [value])) else (if sx_truthy ((is_lambda (f))) then (trampoline ((call_lambda (f) ((List [value])) (fenv)))) else (raise (Eval_error (value_to_str (String (sx_str [(String "-> form not callable: "); (inspect (f))]))))))))) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv))) (rest_k)))))))))) else (if sx_truthy ((prim_call "=" [ft; (String "arg")])) then (let f = (get (frame) ((String "f"))) in let evaled = (get (frame) ((String "evaled"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let raw_args = (get (frame) ((String "raw-args"))) in let hname = (get (frame) ((String "head-name"))) in (if sx_truthy ((is_nil (f))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) ((List []))) else Nil)) in (if sx_truthy ((empty_p (remaining))) then (continue_with_call (value) ((List [])) (fenv) (raw_args) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (value) ((List [])) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))) else (let new_evaled = (prim_call "append" [evaled; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) (new_evaled)) else Nil)) in (continue_with_call (f) (new_evaled) (fenv) (raw_args) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (f) (new_evaled) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "dict")])) then (let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let fenv = (get (frame) ((String "env"))) in (let last_result = (last (results)) in let completed = (prim_call "append" [(prim_call "slice" [results; (Number 0.0); (prim_call "dec" [(len (results))])]); (List [(List [(first (last_result)); value])])]) in (if sx_truthy ((empty_p (remaining))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun pair -> ignore ((sx_dict_set_b d (first (pair)) (nth (pair) ((Number 1.0)))))) (sx_to_list completed); Nil)) in (make_cek_value (d) (fenv) (rest_k)))) else (let next_entry = (first (remaining)) in (make_cek_state ((nth (next_entry) ((Number 1.0)))) (fenv) ((kont_push ((make_dict_frame ((rest (remaining))) ((prim_call "append" [completed; (List [(List [(first (next_entry))])])])) (fenv))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "ho-setup")])) then (let ho_type = (get (frame) ((String "ho-type"))) in let remaining = (get (frame) ((String "remaining"))) in let evaled = (prim_call "append" [(get (frame) ((String "evaled"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (ho_setup_dispatch (ho_type) (evaled) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_ho_setup_frame (ho_type) ((rest (remaining))) (evaled) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "reset")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [ft; (String "deref")])) then (let val' = value in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy ((is_signal (val'))))))) then (make_cek_value (val') (fenv) (rest_k)) else (if sx_truthy ((has_reactive_reset_frame_p (rest_k))) then (reactive_shift_deref (val') (fenv) (rest_k)) else (let () = ignore ((let ctx = (sx_context ((String "sx-reactive")) (Nil)) in (if sx_truthy (ctx) then (let dep_list = ref ((get (ctx) ((String "deps")))) in let notify_fn = (get (ctx) ((String "notify"))) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!dep_list; val'])))))) then (let () = ignore ((dep_list := sx_append_b !dep_list val'; Nil)) in (signal_add_sub_b (val') (notify_fn))) else Nil)) else Nil))) in (make_cek_value ((signal_value (val'))) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "reactive-reset")])) then (let update_fn = (get (frame) ((String "update-fn"))) in let first_p = (get (frame) ((String "first-render"))) in (let () = ignore ((if sx_truthy ((let _and = update_fn in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (first_p)))))) then (cek_call (update_fn) ((List [value]))) else Nil)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [ft; (String "scope")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop (name))) in (make_cek_value (value) (fenv) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_scope_frame (name) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "provide")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "scope-acc")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((let new_frame = (make_scope_acc_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "emitted") (get (frame) ((String "emitted"))))) in new_frame))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let indexed = (get (frame) ((String "indexed"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (prim_call "append" [results; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let call_args = (if sx_truthy (indexed) then (List [(len (new_results)); (first (remaining))]) else (List [(first (remaining))])) in let next_frame = (if sx_truthy (indexed) then (make_map_indexed_frame (f) ((rest (remaining))) (new_results) (fenv)) else (make_map_frame (f) ((rest (remaining))) (new_results) (fenv))) in (continue_with_call (f) (call_args) (fenv) ((List [])) ((kont_push (next_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [ft; (String "filter")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let current_item = (get (frame) ((String "current-item"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (if sx_truthy (value) then (prim_call "append" [results; (List [current_item])]) else results) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (remaining))) (new_results) ((first (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [ft; (String "reduce")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (continue_with_call (f) ((List [value; (first (remaining))])) (fenv) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "for-each")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (Nil) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [ft; (String "some")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy (value) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_some_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [ft; (String "every")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool true)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_every_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown frame type: "); ft])))))))))))))))))))))))))))))))))) (* continue-with-call *) and continue_with_call f args env raw_args kont = @@ -482,7 +486,7 @@ and continue_with_call f args env raw_args kont = (* sf-case-step-loop *) and sf_case_step_loop match_val clauses env kont = - (if sx_truthy ((prim_call "<" [(len (clauses)); (Number 2.0)])) then (make_cek_value (Nil) (env) (kont)) else (let test = (first (clauses)) in let body = (nth (clauses) ((Number 1.0))) in (if sx_truthy ((let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (let _and = (prim_call "=" [(type_of (test)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _or = (prim_call "=" [(symbol_name (test)); (String "else")]) in if sx_truthy _or then _or else (prim_call "=" [(symbol_name (test)); (String ":else")]))))) then (make_cek_state (body) (env) (kont)) else (let test_val = (trampoline ((eval_expr (test) (env)))) in (if sx_truthy ((prim_call "=" [match_val; test_val])) then (make_cek_state (body) (env) (kont)) else (sf_case_step_loop (match_val) ((prim_call "slice" [clauses; (Number 2.0)])) (env) (kont))))))) + (if sx_truthy ((prim_call "<" [(len (clauses)); (Number 2.0)])) then (make_cek_value (Nil) (env) (kont)) else (let test = (first (clauses)) in let body = (nth (clauses) ((Number 1.0))) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state (body) (env) (kont)) else (let test_val = (trampoline ((eval_expr (test) (env)))) in (if sx_truthy ((prim_call "=" [match_val; test_val])) then (make_cek_state (body) (env) (kont)) else (sf_case_step_loop (match_val) ((prim_call "slice" [clauses; (Number 2.0)])) (env) (kont))))))) (* eval-expr-cek *) and eval_expr_cek expr env = @@ -492,66 +496,6 @@ and eval_expr_cek expr env = and trampoline_cek val' = (if sx_truthy ((is_thunk (val'))) then (eval_expr_cek ((thunk_expr (val'))) ((thunk_env (val')))) else val') -(* freeze-registry *) -and freeze_registry = - (Dict (Hashtbl.create 0)) - -(* freeze-signal *) -and freeze_signal = - (String "effects") - -(* freeze-scope *) -and freeze_scope = - (String "effects") - -(* cek-freeze-scope *) -and cek_freeze_scope = - (String "effects") - -(* cek-freeze-all *) -and cek_freeze_all = - (String "effects") - -(* cek-thaw-scope *) -and cek_thaw_scope = - (String "effects") - -(* cek-thaw-all *) -and cek_thaw_all = - (String "effects") - -(* freeze-to-sx *) -and freeze_to_sx = - (String "effects") - -(* thaw-from-sx *) -and thaw_from_sx = - (String "effects") - -(* content-store *) -and content_store = - (Dict (Hashtbl.create 0)) - -(* content-hash *) -and content_hash = - (String "effects") - -(* content-put *) -and content_put = - (String "effects") - -(* content-get *) -and content_get = - (String "effects") - -(* freeze-to-cid *) -and freeze_to_cid = - (String "effects") - -(* thaw-from-cid *) -and thaw_from_cid = - (String "effects") - (* eval-expr *) and eval_expr expr env = (cek_run ((make_cek_state (expr) (env) ((List []))))) diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index eedb293..93d4376 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -297,10 +297,26 @@ let scope_pop _name = Nil let provide_push name value = ignore name; ignore value; Nil let provide_pop _name = Nil -(* Render mode stubs *) -let render_active_p () = Bool false -let render_expr _expr _env = Nil -let is_render_expr _expr = Bool false +(* Custom special forms registry — mutable dict *) +let custom_special_forms = Dict (Hashtbl.create 4) + +(* register-special-form! — add a handler to the custom registry *) +let register_special_form name handler = + (match custom_special_forms with + | Dict tbl -> Hashtbl.replace tbl (value_to_str name) handler; handler + | _ -> raise (Eval_error "custom_special_forms not a dict")) + +(* Render check/fn hooks — nil by default, set by platform if needed *) +let render_check = Nil +let render_fn = Nil + +(* is-else-clause? — check if a cond/case test is an else marker *) +let is_else_clause v = + match v with + | Keyword k -> Bool (k = "else" || k = "default") + | Symbol s -> Bool (s = "else" || s = "default") + | Bool true -> Bool true + | _ -> Bool false (* Signal accessors *) let signal_value s = match s with Signal sig' -> sig'.s_value | _ -> raise (Eval_error "not a signal") diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index 00e0dcb..9d46685 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -123,9 +123,11 @@ "provide-push!" "provide_push" "provide-pop!" "provide_pop" "sx-serialize" "sx_serialize" - "render-active?" "render_active_p" - "is-render-expr?" "is_render_expr" - "render-expr" "render_expr" + "*custom-special-forms*" "custom_special_forms" + "register-special-form!" "register_special_form" + "*render-check*" "render_check" + "*render-fn*" "render_fn" + "is-else-clause?" "is_else_clause" "HTML_TAGS" "html_tags" "VOID_ELEMENTS" "void_elements" "BOOLEAN_ATTRS" "boolean_attrs" @@ -192,15 +194,12 @@ "cek-call" "cek-run" "sx-call" "sx-apply" "collect!" "collected" "clear-collected!" "context" "emit!" "emitted" "scope-push!" "scope-pop!" "provide-push!" "provide-pop!" - "render-active?" "render-expr" "is-render-expr?" "with-island-scope" "register-in-scope" "signal-value" "signal-set-value" "signal-subscribers" "signal-add-sub!" "signal-remove-sub!" "signal-deps" "signal-set-deps" "notify-subscribers" "flush-subscribers" "dispose-computed" "continuation?" "continuation-data" "make-cek-continuation" "dynamic-wind-call" "strip-prefix" - "sf-defhandler" "sf-defpage" "sf-defquery" "sf-defaction" - "make-handler-def" "make-query-def" "make-action-def" "make-page-def" "component-set-param-types!" "parse-comp-params" "parse-macro-params" "parse-keyword-args")) @@ -215,6 +214,15 @@ ;; Check _known_defines (set by bootstrap.py) (some (fn (d) (= d name)) _known_defines))))) +;; Dynamic globals — top-level defines that hold SX values (not functions). +;; When these appear as callees, use cek_call for dynamic dispatch. +(define ml-dynamic-globals + (list "*render-check*" "*render-fn*")) + +(define ml-is-dyn-global? + (fn ((name :as string)) + (some (fn (g) (= g name)) ml-dynamic-globals))) + ;; Check if a variable is "dynamic" — locally bound to a non-function expression. ;; These variables hold SX values (from eval-expr, get, etc.) and need cek_call ;; when used as callees. We encode this in the set-vars list as "dyn:name". @@ -421,8 +429,12 @@ (let ((head (first expr)) (args (rest expr))) (if (not (= (type-of head) "symbol")) - ;; Data list - (str "[" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) expr)) "]") + ;; Non-symbol head: if head is a list (call expr), dispatch via cek_call; + ;; otherwise treat as data list + (if (list? head) + (str "(cek_call (" (ml-expr-inner head set-vars) + ") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))") + (str "[" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) expr)) "]")) (let ((op (symbol-name head))) (cond ;; fn/lambda @@ -607,8 +619,8 @@ ;; Regular function call :else (let ((callee (ml-mangle op))) - (if (ml-is-dyn-var? op set-vars) - ;; Dynamic callee (local var bound to non-fn expr) — dispatch via cek_call + (if (or (ml-is-dyn-var? op set-vars) (ml-is-dyn-global? op)) + ;; Dynamic callee (local var or dynamic global) — dispatch via cek_call (str "(cek_call (" callee ") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))") ;; Static callee — direct OCaml call (if (empty? args) diff --git a/hosts/python/bootstrap.py b/hosts/python/bootstrap.py index 0b9798a..0270000 100644 --- a/hosts/python/bootstrap.py +++ b/hosts/python/bootstrap.py @@ -179,6 +179,11 @@ class PyEmitter: "*batch-depth*": "_batch_depth", "*batch-queue*": "_batch_queue", "*store-registry*": "_store_registry", + "*custom-special-forms*": "_custom_special_forms", + "*render-check*": "_render_check", + "*render-fn*": "_render_fn", + "register-special-form!": "register_special_form_b", + "is-else-clause?": "is_else_clause_p", "def-store": "def_store", "use-store": "use_store", "clear-stores": "clear_stores", diff --git a/hosts/python/platform.py b/hosts/python/platform.py index 4c23683..fcf660a 100644 --- a/hosts/python/platform.py +++ b/hosts/python/platform.py @@ -612,13 +612,7 @@ def inspect(x): return repr(x) -def escape_html(s): - s = str(s) - return s.replace("&", "&").replace("<", "<").replace(">", ">").replace('"', """) - - -def escape_attr(s): - return escape_html(s) +# escape_html and escape_attr are now library functions defined in render.sx def raw_html_content(x): @@ -842,7 +836,7 @@ def _sx_parse_int(v, default=0): "stdlib.text": ''' # stdlib.text PRIMITIVES["pluralize"] = lambda n, s="", p="s": s if n == 1 else p -PRIMITIVES["escape"] = escape_html +PRIMITIVES["escape"] = lambda s: str(s).replace("&", "&").replace("<", "<").replace(">", ">").replace('"', """) PRIMITIVES["strip-tags"] = lambda s: _strip_tags(str(s)) import re as _re @@ -1647,12 +1641,15 @@ SPEC_MODULES = { "signals": ("signals.sx", "signals (reactive signal runtime)"), "page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"), "types": ("types.sx", "types (gradual type system)"), + "freeze": ("freeze.sx", "freeze (serializable state boundaries)"), + "content": ("content.sx", "content (content-addressed computation)"), } # Note: frames and cek are now part of evaluator.sx (always loaded as core) # Explicit ordering for spec modules with dependencies. +# freeze depends on signals; content depends on freeze. SPEC_MODULE_ORDER = [ - "deps", "engine", "page-helpers", "router", "signals", "types", + "deps", "engine", "page-helpers", "router", "signals", "types", "freeze", "content", ] EXTENSION_NAMES = {"continuations"} diff --git a/hosts/python/tests/run_cek_tests.py b/hosts/python/tests/run_cek_tests.py index dfecd5e..20ffbc8 100644 --- a/hosts/python/tests/run_cek_tests.py +++ b/hosts/python/tests/run_cek_tests.py @@ -172,9 +172,6 @@ env["sf-lambda"] = sx_ref.sf_lambda env["sf-defcomp"] = sx_ref.sf_defcomp env["sf-defisland"] = sx_ref.sf_defisland env["sf-defmacro"] = sx_ref.sf_defmacro -env["sf-defstyle"] = sx_ref.sf_defstyle -env["sf-deftype"] = sx_ref.sf_deftype -env["sf-defeffect"] = sx_ref.sf_defeffect env["sf-letrec"] = sx_ref.sf_letrec env["sf-named-let"] = sx_ref.sf_named_let env["sf-dynamic-wind"] = sx_ref.sf_dynamic_wind @@ -194,10 +191,25 @@ env["ho-every"] = sx_ref.ho_every env["ho-for-each"] = sx_ref.ho_for_each env["call-fn"] = sx_ref.call_fn -# Render-related (stub for testing — no active rendering) -env["render-active?"] = lambda: False -env["is-render-expr?"] = lambda expr: False -env["render-expr"] = lambda expr, env: NIL +# Render dispatch globals — evaluator checks *render-check* and *render-fn* +env["*render-check*"] = NIL +env["*render-fn*"] = NIL + +# Custom special forms registry — modules register forms at load time +env["*custom-special-forms*"] = {} +def _register_special_form(name, handler): + env["*custom-special-forms*"][name] = handler + return NIL +env["register-special-form!"] = _register_special_form + +# is-else-clause? — check if a cond/case test is an else marker +def _is_else_clause(test): + if isinstance(test, Keyword) and test.name == "else": + return True + if isinstance(test, Symbol) and test.name in ("else", ":else"): + return True + return False +env["is-else-clause?"] = _is_else_clause # Scope primitives env["scope-push!"] = sx_ref.PRIMITIVES.get("scope-push!", lambda *a: NIL) @@ -214,15 +226,12 @@ env["call-thunk"] = lambda f, e: f() if callable(f) else trampoline(eval_expr([f # Mutation helpers used by parse-keyword-args etc env["dict-get"] = lambda d, k: d.get(k, NIL) if isinstance(d, dict) else NIL -# defhandler, defpage, defquery, defaction — these are registrations -# Use the bootstrapped versions if they exist, otherwise stub -for name in ["sf-defhandler", "sf-defpage", "sf-defquery", "sf-defaction"]: - pyname = name.replace("-", "_") - fn = getattr(sx_ref, pyname, None) - if fn: - env[name] = fn - else: - env[name] = lambda args, e, _n=name: NIL +# defstyle, defhandler, defpage, defquery, defaction — now registered via +# register-special-form! by forms.sx at load time. Stub them here in case +# forms.sx is not loaded (CEK tests don't load it). +for form_name in ["defstyle", "defhandler", "defpage", "defquery", "defaction"]: + if form_name not in env["*custom-special-forms*"]: + env["*custom-special-forms*"][form_name] = lambda args, e, _n=form_name: NIL # Load test framework with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f: diff --git a/hosts/python/tests/run_tests.py b/hosts/python/tests/run_tests.py index 9c5f10c..0324589 100644 --- a/hosts/python/tests/run_tests.py +++ b/hosts/python/tests/run_tests.py @@ -248,9 +248,26 @@ env["macro-closure"] = lambda m: m.closure env["symbol-name"] = lambda s: s.name if isinstance(s, Symbol) else str(s) env["keyword-name"] = lambda k: k.name if isinstance(k, Keyword) else str(k) env["sx-serialize"] = sx_ref.sx_serialize if hasattr(sx_ref, "sx_serialize") else lambda x: str(x) -env["is-render-expr?"] = lambda expr: False -env["render-active?"] = lambda: False -env["render-expr"] = lambda expr, env: NIL + +# Render dispatch globals — evaluator checks *render-check* and *render-fn* +env["*render-check*"] = NIL +env["*render-fn*"] = NIL + +# Custom special forms registry — modules register forms at load time +env["*custom-special-forms*"] = {} +def _register_special_form(name, handler): + env["*custom-special-forms*"][name] = handler + return NIL +env["register-special-form!"] = _register_special_form + +# is-else-clause? — check if a cond/case test is an else marker +def _is_else_clause(test): + if isinstance(test, Keyword) and test.name == "else": + return True + if isinstance(test, Symbol) and test.name in ("else", ":else"): + return True + return False +env["is-else-clause?"] = _is_else_clause # Strict mode stubs (not yet bootstrapped to Python — no-ops for now) env["set-strict!"] = lambda val: NIL diff --git a/hosts/python/transpiler.sx b/hosts/python/transpiler.sx index e242b6c..253188c 100644 --- a/hosts/python/transpiler.sx +++ b/hosts/python/transpiler.sx @@ -93,6 +93,11 @@ "*batch-depth*" "_batch_depth" "*batch-queue*" "_batch_queue" "*store-registry*" "_store_registry" + "*custom-special-forms*" "_custom_special_forms" + "*render-check*" "_render_check" + "*render-fn*" "_render_fn" + "register-special-form!" "register_special_form_b" + "is-else-clause?" "is_else_clause_p" "def-store" "def_store" "use-store" "use_store" "clear-stores" "clear_stores" diff --git a/spec/content.sx b/spec/content.sx new file mode 100644 index 0000000..69370ed --- /dev/null +++ b/spec/content.sx @@ -0,0 +1,48 @@ +;; ========================================================================== +;; content.sx — Content-addressed computation +;; +;; Hash frozen SX to a content identifier. Store and retrieve by CID. +;; The content IS the address — same SX always produces the same CID. +;; +;; This is a library built on top of freeze.sx. It is NOT part of the +;; core evaluator. Load order: evaluator.sx → freeze.sx → content.sx +;; +;; Uses an in-memory content store. Applications can persist to +;; localStorage or IPFS by providing their own store backend. +;; ========================================================================== + +(define content-store (dict)) + +(define content-hash :effects [] + (fn (sx-text) + ;; djb2 hash → hex string. Simple, deterministic, fast. + ;; Real deployment would use SHA-256 / multihash. + (let ((hash 5381)) + (for-each (fn (i) + (set! hash (mod (+ (* hash 33) (char-code-at sx-text i)) 4294967296))) + (range 0 (len sx-text))) + (to-hex hash)))) + +(define content-put :effects [mutation] + (fn (sx-text) + (let ((cid (content-hash sx-text))) + (dict-set! content-store cid sx-text) + cid))) + +(define content-get :effects [] + (fn (cid) + (get content-store cid))) + +;; Freeze a scope → store → return CID +(define freeze-to-cid :effects [mutation] + (fn (scope-name) + (let ((sx-text (freeze-to-sx scope-name))) + (content-put sx-text)))) + +;; Thaw from CID → look up → restore +(define thaw-from-cid :effects [mutation] + (fn (cid) + (let ((sx-text (content-get cid))) + (when sx-text + (thaw-from-sx sx-text) + true)))) diff --git a/spec/evaluator.sx b/spec/evaluator.sx index f5966a7..93a5266 100644 --- a/spec/evaluator.sx +++ b/spec/evaluator.sx @@ -306,6 +306,26 @@ (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) + (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 ;; ************************************************************************** @@ -545,6 +565,14 @@ (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. @@ -755,91 +783,6 @@ (list params rest-param)))) -(define sf-defstyle - (fn ((args :as list) (env :as dict)) - ;; (defstyle name expr) — bind name to evaluated expr (string, function, etc.) - (let ((name-sym (first args)) - (value (trampoline (eval-expr (nth args 1) env)))) - (env-bind! env (symbol-name name-sym) value) - value))) - - -;; -- deftype helpers (must be in eval.sx, not types.sx, because -;; sf-deftype is always compiled but types.sx is a spec module) -- - -(define make-type-def - (fn ((name :as string) (params :as list) body) - {:name name :params params :body body})) - -(define normalize-type-body - (fn (body) - ;; Convert AST type expressions to type representation. - ;; Symbols → strings, (union ...) → (or ...), dict keys → strings. - (cond - (nil? body) "nil" - (= (type-of body) "symbol") - (symbol-name body) - (= (type-of body) "string") - body - (= (type-of body) "keyword") - (keyword-name body) - (= (type-of body) "dict") - ;; Record type — normalize values - (map-dict (fn (k v) (normalize-type-body v)) body) - (= (type-of body) "list") - (if (empty? body) "any" - (let ((head (first body))) - (let ((head-name (if (= (type-of head) "symbol") - (symbol-name head) (str head)))) - ;; (union a b) → (or a b) - (if (= head-name "union") - (cons "or" (map normalize-type-body (rest body))) - ;; (or a b), (list-of t), (-> ...) etc. - (cons head-name (map normalize-type-body (rest body))))))) - :else (str body)))) - -(define sf-deftype - (fn ((args :as list) (env :as dict)) - ;; (deftype name body) or (deftype (name a b ...) body) - (let ((name-or-form (first args)) - (body-expr (nth args 1)) - (type-name nil) - (type-params (list))) - ;; Parse name — symbol or (symbol params...) - (if (= (type-of name-or-form) "symbol") - (set! type-name (symbol-name name-or-form)) - (when (= (type-of name-or-form) "list") - (set! type-name (symbol-name (first name-or-form))) - (set! type-params - (map (fn (p) (if (= (type-of p) "symbol") - (symbol-name p) (str p))) - (rest name-or-form))))) - ;; Normalize and store in *type-registry* - (let ((body (normalize-type-body body-expr)) - (registry (if (env-has? env "*type-registry*") - (env-get env "*type-registry*") - (dict)))) - (dict-set! registry type-name - (make-type-def type-name type-params body)) - (env-bind! env "*type-registry*" registry) - nil)))) - - -(define sf-defeffect - (fn ((args :as list) (env :as dict)) - ;; (defeffect name) — register an effect name - (let ((effect-name (if (= (type-of (first args)) "symbol") - (symbol-name (first args)) - (str (first args)))) - (registry (if (env-has? env "*effect-registry*") - (env-get env "*effect-registry*") - (list)))) - (when (not (contains? registry effect-name)) - (append! registry effect-name)) - (env-bind! env "*effect-registry*" registry) - nil))) - - (define qq-expand (fn (template (env :as dict)) (if (not (= (type-of template) "list")) @@ -1126,10 +1069,11 @@ ;; (pop-wind!) → void (pop wind record from stack) ;; (call-thunk f env) → value (call a zero-arg function) ;; -;; Render-time accumulators: -;; (collect! bucket value) → void (add to named bucket, deduplicated) -;; (collected bucket) → list (all values in bucket) -;; (clear-collected! bucket) → void (empty the bucket) +;; 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 ;; -------------------------------------------------------------------------- @@ -1262,13 +1206,6 @@ (= 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 "defstyle") (make-cek-value (sf-defstyle args env) env kont) - (= name "defhandler") (make-cek-value (sf-defhandler args env) env kont) - (= name "defpage") (make-cek-value (sf-defpage args env) env kont) - (= name "defquery") (make-cek-value (sf-defquery args env) env kont) - (= name "defaction") (make-cek-value (sf-defaction args env) env kont) - (= name "deftype") (make-cek-value (sf-deftype args env) env kont) - (= name "defeffect") (make-cek-value (sf-defeffect 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) @@ -1303,14 +1240,20 @@ (= name "every?") (step-ho-every args env kont) (= name "for-each") (step-ho-for-each args env kont) + ;; Custom special forms (registered by extensions) + (has-key? *custom-special-forms* name) + (make-cek-value + ((get *custom-special-forms* name) args env) + env kont) + ;; Macro expansion (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 expression - (and (render-active?) (is-render-expr? expr)) - (make-cek-value (render-expr expr env) env kont) + ;; Render dispatch (installed by web adapters) + (and *render-check* (*render-check* expr env)) + (make-cek-value (*render-fn* expr env) env kont) ;; Fall through to function call :else (step-eval-call head args env kont))) @@ -1451,11 +1394,7 @@ (let ((clause (first args)) (test (first clause))) ;; Check for :else / else - (if (or (and (= (type-of test) "symbol") - (or (= (symbol-name test) "else") - (= (symbol-name test) ":else"))) - (and (= (type-of test) "keyword") - (= (keyword-name test) "else"))) + (if (is-else-clause? test) (make-cek-state (nth clause 1) env kont) (make-cek-state test env @@ -1464,10 +1403,7 @@ (if (< (len args) 2) (make-cek-value nil env kont) (let ((test (first args))) - (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) - (and (= (type-of test) "symbol") - (or (= (symbol-name test) "else") - (= (symbol-name test) ":else")))) + (if (is-else-clause? test) (make-cek-state (nth args 1) env kont) (make-cek-state test env @@ -1950,11 +1886,7 @@ (make-cek-value nil fenv rest-k) (let ((next-clause (first next-clauses)) (next-test (first next-clause))) - (if (or (and (= (type-of next-test) "symbol") - (or (= (symbol-name next-test) "else") - (= (symbol-name next-test) ":else"))) - (and (= (type-of next-test) "keyword") - (= (keyword-name next-test) "else"))) + (if (is-else-clause? next-test) (make-cek-state (nth next-clause 1) fenv rest-k) (make-cek-state next-test fenv @@ -1966,10 +1898,7 @@ (if (< (len next) 2) (make-cek-value nil fenv rest-k) (let ((next-test (first next))) - (if (or (and (= (type-of next-test) "keyword") (= (keyword-name next-test) "else")) - (and (= (type-of next-test) "symbol") - (or (= (symbol-name next-test) "else") - (= (symbol-name next-test) ":else")))) + (if (is-else-clause? next-test) (make-cek-state (nth next 1) fenv rest-k) (make-cek-state next-test fenv @@ -2336,10 +2265,7 @@ (make-cek-value nil env kont) (let ((test (first clauses)) (body (nth clauses 1))) - (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) - (and (= (type-of test) "symbol") - (or (= (symbol-name test) "else") - (= (symbol-name test) ":else")))) + (if (is-else-clause? test) (make-cek-state body env kont) ;; Evaluate test expression (let ((test-val (trampoline (eval-expr test env)))) @@ -2368,150 +2294,6 @@ val))) - -;; -------------------------------------------------------------------------- -;; 13. Freeze scopes — named serializable state boundaries -;; -------------------------------------------------------------------------- -;; -;; A freeze scope collects signals registered within it. On freeze, -;; their current values are serialized to SX. On thaw, values are -;; restored. Multiple named scopes can coexist independently. -;; -;; Uses the scoped effects system: scope-push!/scope-pop!/context. -;; -;; Usage: -;; (freeze-scope "editor" -;; (let ((doc (signal "hello"))) -;; (freeze-signal "doc" doc) -;; ...)) -;; -;; (cek-freeze-scope "editor") → {:name "editor" :signals {:doc "hello"}} -;; (cek-thaw-scope "editor" frozen-data) → restores signal values - -;; Registry of freeze scopes: name → list of {name signal} entries -(define freeze-registry (dict)) - -;; Register a signal in the current freeze scope -(define freeze-signal :effects [mutation] - (fn (name sig) - (let ((scope-name (context "sx-freeze-scope" nil))) - (when scope-name - (let ((entries (or (get freeze-registry scope-name) (list)))) - (append! entries (dict "name" name "signal" sig)) - (dict-set! freeze-registry scope-name entries)))))) - -;; Freeze scope delimiter — collects signals registered within body -(define freeze-scope :effects [mutation] - (fn (name body-fn) - (scope-push! "sx-freeze-scope" name) - ;; Initialize empty entry list for this scope - (dict-set! freeze-registry name (list)) - (cek-call body-fn nil) - (scope-pop! "sx-freeze-scope") - nil)) - -;; Freeze a named scope → SX dict of signal values -(define cek-freeze-scope :effects [] - (fn (name) - (let ((entries (or (get freeze-registry name) (list))) - (signals-dict (dict))) - (for-each (fn (entry) - (dict-set! signals-dict - (get entry "name") - (signal-value (get entry "signal")))) - entries) - (dict "name" name "signals" signals-dict)))) - -;; Freeze all scopes -(define cek-freeze-all :effects [] - (fn () - (map (fn (name) (cek-freeze-scope name)) - (keys freeze-registry)))) - -;; Thaw a named scope — restore signal values from frozen data -(define cek-thaw-scope :effects [mutation] - (fn (name frozen) - (let ((entries (or (get freeze-registry name) (list))) - (values (get frozen "signals"))) - (when values - (for-each (fn (entry) - (let ((sig-name (get entry "name")) - (sig (get entry "signal")) - (val (get values sig-name))) - (when (not (nil? val)) - (reset! sig val)))) - entries))))) - -;; Thaw all scopes from a list of frozen scope dicts -(define cek-thaw-all :effects [mutation] - (fn (frozen-list) - (for-each (fn (frozen) - (cek-thaw-scope (get frozen "name") frozen)) - frozen-list))) - -;; Serialize a frozen scope to SX text -(define freeze-to-sx :effects [] - (fn (name) - (sx-serialize (cek-freeze-scope name)))) - -;; Restore from SX text -(define thaw-from-sx :effects [mutation] - (fn (sx-text) - (let ((parsed (sx-parse sx-text))) - (when (not (empty? parsed)) - (let ((frozen (first parsed))) - (cek-thaw-scope (get frozen "name") frozen)))))) - - - - -;; -------------------------------------------------------------------------- -;; 14. Content-addressed computation -;; -------------------------------------------------------------------------- -;; -;; Hash frozen SX to a content identifier. Store and retrieve by CID. -;; The content IS the address — same SX always produces the same CID. -;; -;; Uses an in-memory content store. Applications can persist to -;; localStorage or IPFS by providing their own store backend. - -(define content-store (dict)) - -(define content-hash :effects [] - (fn (sx-text) - ;; djb2 hash → hex string. Simple, deterministic, fast. - ;; Real deployment would use SHA-256 / multihash. - (let ((hash 5381)) - (for-each (fn (i) - (set! hash (mod (+ (* hash 33) (char-code-at sx-text i)) 4294967296))) - (range 0 (len sx-text))) - (to-hex hash)))) - -(define content-put :effects [mutation] - (fn (sx-text) - (let ((cid (content-hash sx-text))) - (dict-set! content-store cid sx-text) - cid))) - -(define content-get :effects [] - (fn (cid) - (get content-store cid))) - -;; Freeze a scope → store → return CID -(define freeze-to-cid :effects [mutation] - (fn (scope-name) - (let ((sx-text (freeze-to-sx scope-name))) - (content-put sx-text)))) - -;; Thaw from CID → look up → restore -(define thaw-from-cid :effects [mutation] - (fn (cid) - (let ((sx-text (content-get cid))) - (when sx-text - (thaw-from-sx sx-text) - true)))) - - ;; ************************************************************************** ;; eval-expr / trampoline — canonical definitions (after cek-run is defined) ;; ************************************************************************** diff --git a/spec/freeze.sx b/spec/freeze.sx new file mode 100644 index 0000000..f3c2e97 --- /dev/null +++ b/spec/freeze.sx @@ -0,0 +1,94 @@ +;; ========================================================================== +;; freeze.sx — Serializable state boundaries +;; +;; Freeze scopes collect signals registered within them. On freeze, +;; their current values are serialized to SX. On thaw, values are +;; restored. Multiple named scopes can coexist independently. +;; +;; This is a library built on top of the evaluator's scoped effects +;; (scope-push!/scope-pop!/context) and signal system. It is NOT +;; part of the core evaluator — it loads after evaluator.sx. +;; +;; Usage: +;; (freeze-scope "editor" +;; (let ((doc (signal "hello"))) +;; (freeze-signal "doc" doc) +;; ...)) +;; +;; (cek-freeze-scope "editor") → {:name "editor" :signals {:doc "hello"}} +;; (cek-thaw-scope "editor" frozen-data) → restores signal values +;; ========================================================================== + +;; Registry of freeze scopes: name → list of {name signal} entries +(define freeze-registry (dict)) + +;; Register a signal in the current freeze scope +(define freeze-signal :effects [mutation] + (fn (name sig) + (let ((scope-name (context "sx-freeze-scope" nil))) + (when scope-name + (let ((entries (or (get freeze-registry scope-name) (list)))) + (append! entries (dict "name" name "signal" sig)) + (dict-set! freeze-registry scope-name entries)))))) + +;; Freeze scope delimiter — collects signals registered within body +(define freeze-scope :effects [mutation] + (fn (name body-fn) + (scope-push! "sx-freeze-scope" name) + ;; Initialize empty entry list for this scope + (dict-set! freeze-registry name (list)) + (cek-call body-fn nil) + (scope-pop! "sx-freeze-scope") + nil)) + +;; Freeze a named scope → SX dict of signal values +(define cek-freeze-scope :effects [] + (fn (name) + (let ((entries (or (get freeze-registry name) (list))) + (signals-dict (dict))) + (for-each (fn (entry) + (dict-set! signals-dict + (get entry "name") + (signal-value (get entry "signal")))) + entries) + (dict "name" name "signals" signals-dict)))) + +;; Freeze all scopes +(define cek-freeze-all :effects [] + (fn () + (map (fn (name) (cek-freeze-scope name)) + (keys freeze-registry)))) + +;; Thaw a named scope — restore signal values from frozen data +(define cek-thaw-scope :effects [mutation] + (fn (name frozen) + (let ((entries (or (get freeze-registry name) (list))) + (values (get frozen "signals"))) + (when values + (for-each (fn (entry) + (let ((sig-name (get entry "name")) + (sig (get entry "signal")) + (val (get values sig-name))) + (when (not (nil? val)) + (reset! sig val)))) + entries))))) + +;; Thaw all scopes from a list of frozen scope dicts +(define cek-thaw-all :effects [mutation] + (fn (frozen-list) + (for-each (fn (frozen) + (cek-thaw-scope (get frozen "name") frozen)) + frozen-list))) + +;; Serialize a frozen scope to SX text +(define freeze-to-sx :effects [] + (fn (name) + (sx-serialize (cek-freeze-scope name)))) + +;; Restore from SX text +(define thaw-from-sx :effects [mutation] + (fn (sx-text) + (let ((parsed (sx-parse sx-text))) + (when (not (empty? parsed)) + (let ((frozen (first parsed))) + (cek-thaw-scope (get frozen "name") frozen)))))) diff --git a/spec/render.sx b/spec/render.sx index d05516c..4112096 100644 --- a/spec/render.sx +++ b/spec/render.sx @@ -146,11 +146,7 @@ (let ((clause (first clauses)) (test (first clause)) (body (nth clause 1))) - (if (or (and (= (type-of test) "symbol") - (or (= (symbol-name test) "else") - (= (symbol-name test) ":else"))) - (and (= (type-of test) "keyword") - (= (keyword-name test) "else"))) + (if (is-else-clause? test) body (if (trampoline (eval-expr test env)) body @@ -162,10 +158,7 @@ nil (let ((test (first clauses)) (body (nth clauses 1))) - (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) - (and (= (type-of test) "symbol") - (or (= (symbol-name test) "else") - (= (symbol-name test) ":else")))) + (if (is-else-clause? test) body (if (trampoline (eval-expr test env)) body @@ -250,13 +243,28 @@ (keys spread-dict)))) +;; -------------------------------------------------------------------------- +;; HTML escaping — library functions (pure text processing) +;; -------------------------------------------------------------------------- + +(define escape-html + (fn (s) + (-> (str s) + (replace "&" "&") + (replace "<" "<") + (replace ">" ">") + (replace "\"" """)))) + +(define escape-attr + (fn (s) + (escape-html s))) + + ;; -------------------------------------------------------------------------- ;; Platform interface (shared across adapters) ;; -------------------------------------------------------------------------- ;; -;; HTML/attribute escaping (used by HTML and SX wire adapters): -;; (escape-html s) → HTML-escaped string -;; (escape-attr s) → attribute-value-escaped string +;; Raw HTML (marker type for unescaped content): ;; (raw-html-content r) → unwrap RawHTML marker to string ;; ;; Spread (render-time attribute injection): diff --git a/spec/tests/test-eval.sx b/spec/tests/test-eval.sx index 33885f7..d9ebfd0 100644 --- a/spec/tests/test-eval.sx +++ b/spec/tests/test-eval.sx @@ -566,181 +566,3 @@ (assert-equal 0 (len (list))) (assert-equal "" (str)))) - -;; -------------------------------------------------------------------------- -;; Server-only tests — skip in browser (defpage, streaming functions) -;; These require forms.sx which is only loaded server-side. -;; -------------------------------------------------------------------------- - -(when (get (try-call (fn () stream-chunk-id)) "ok") - -(defsuite "defpage" - (deftest "basic defpage returns page-def" - (let ((p (defpage test-basic :path "/test" :auth :public :content (div "hello")))) - (assert-true (not (nil? p))) - (assert-equal "test-basic" (get p "name")) - (assert-equal "/test" (get p "path")) - (assert-equal "public" (get p "auth")))) - - (deftest "defpage content expr is unevaluated AST" - (let ((p (defpage test-content :path "/c" :auth :public :content (~my-comp :title "hi")))) - (assert-true (not (nil? (get p "content")))))) - - (deftest "defpage with :stream" - (let ((p (defpage test-stream :path "/s" :auth :public :stream true :content (div "x")))) - (assert-equal true (get p "stream")))) - - (deftest "defpage with :shell" - (let ((p (defpage test-shell :path "/sh" :auth :public :stream true - :shell (~my-layout (~suspense :id "data" :fallback (div "loading..."))) - :content (~my-streamed :data data-val)))) - (assert-true (not (nil? (get p "shell")))) - (assert-true (not (nil? (get p "content")))))) - - (deftest "defpage with :fallback" - (let ((p (defpage test-fallback :path "/f" :auth :public :stream true - :fallback (div :class "skeleton" "loading") - :content (div "done")))) - (assert-true (not (nil? (get p "fallback")))))) - - (deftest "defpage with :data" - (let ((p (defpage test-data :path "/d" :auth :public - :data (fetch-items) - :content (~items-list :items items)))) - (assert-true (not (nil? (get p "data")))))) - - (deftest "defpage missing fields are nil" - (let ((p (defpage test-minimal :path "/m" :auth :public :content (div "x")))) - (assert-nil (get p "data")) - (assert-nil (get p "filter")) - (assert-nil (get p "aside")) - (assert-nil (get p "menu")) - (assert-nil (get p "shell")) - (assert-nil (get p "fallback")) - (assert-equal false (get p "stream"))))) - -;; -------------------------------------------------------------------------- -;; Multi-stream data protocol (from forms.sx) -;; -------------------------------------------------------------------------- - -(defsuite "stream-chunk-id" - (deftest "extracts stream-id from chunk" - (assert-equal "my-slot" (stream-chunk-id {"stream-id" "my-slot" "x" 1}))) - - (deftest "defaults to stream-content when missing" - (assert-equal "stream-content" (stream-chunk-id {"x" 1 "y" 2})))) - -(defsuite "stream-chunk-bindings" - (deftest "removes stream-id from chunk" - (let ((bindings (stream-chunk-bindings {"stream-id" "slot" "name" "alice" "age" 30}))) - (assert-equal "alice" (get bindings "name")) - (assert-equal 30 (get bindings "age")) - (assert-nil (get bindings "stream-id")))) - - (deftest "returns all keys when no stream-id" - (let ((bindings (stream-chunk-bindings {"a" 1 "b" 2}))) - (assert-equal 1 (get bindings "a")) - (assert-equal 2 (get bindings "b"))))) - -(defsuite "normalize-binding-key" - (deftest "converts underscores to hyphens" - (assert-equal "my-key" (normalize-binding-key "my_key"))) - - (deftest "leaves hyphens unchanged" - (assert-equal "my-key" (normalize-binding-key "my-key"))) - - (deftest "handles multiple underscores" - (assert-equal "a-b-c" (normalize-binding-key "a_b_c")))) - -(defsuite "bind-stream-chunk" - (deftest "creates fresh env with bindings" - (let ((base {"existing" 42}) - (chunk {"stream-id" "slot" "user-name" "bob" "count" 5}) - (env (bind-stream-chunk chunk base))) - ;; Base env bindings are preserved - (assert-equal 42 (get env "existing")) - ;; Chunk bindings are added (stream-id removed) - (assert-equal "bob" (get env "user-name")) - (assert-equal 5 (get env "count")) - ;; stream-id is not in env - (assert-nil (get env "stream-id")))) - - (deftest "isolates env from base — bindings don't leak to base" - (let ((base {"x" 1}) - (chunk {"stream-id" "s" "y" 2}) - (env (bind-stream-chunk chunk base))) - ;; Chunk bindings should not appear in base - (assert-nil (get base "y")) - ;; Base bindings should be in derived env - (assert-equal 1 (get env "x"))))) - -(defsuite "validate-stream-data" - (deftest "valid: list of dicts" - (assert-true (validate-stream-data - (list {"stream-id" "a" "x" 1} - {"stream-id" "b" "y" 2})))) - - (deftest "valid: empty list" - (assert-true (validate-stream-data (list)))) - - (deftest "invalid: single dict (not a list)" - (assert-equal false (validate-stream-data {"x" 1}))) - - (deftest "invalid: list containing non-dict" - (assert-equal false (validate-stream-data (list {"x" 1} "oops" {"y" 2}))))) - - -;; -------------------------------------------------------------------------- -;; Multi-stream end-to-end scenarios -;; -------------------------------------------------------------------------- - -(defsuite "multi-stream routing" - (deftest "stream-chunk-id routes different chunks to different slots" - (let ((chunks (list - {"stream-id" "stream-fast" "msg" "quick"} - {"stream-id" "stream-medium" "msg" "steady"} - {"stream-id" "stream-slow" "msg" "slow"})) - (ids (map stream-chunk-id chunks))) - (assert-equal "stream-fast" (nth ids 0)) - (assert-equal "stream-medium" (nth ids 1)) - (assert-equal "stream-slow" (nth ids 2)))) - - (deftest "bind-stream-chunk creates isolated envs per chunk" - (let ((base {"layout" "main"}) - (chunk-a {"stream-id" "a" "title" "First" "count" 1}) - (chunk-b {"stream-id" "b" "title" "Second" "count" 2}) - (env-a (bind-stream-chunk chunk-a base)) - (env-b (bind-stream-chunk chunk-b base))) - ;; Each env has its own bindings - (assert-equal "First" (get env-a "title")) - (assert-equal "Second" (get env-b "title")) - (assert-equal 1 (get env-a "count")) - (assert-equal 2 (get env-b "count")) - ;; Both share base - (assert-equal "main" (get env-a "layout")) - (assert-equal "main" (get env-b "layout")) - ;; Neither leaks into base - (assert-nil (get base "title")))) - - (deftest "normalize-binding-key applied to chunk keys" - (let ((chunk {"stream-id" "s" "user_name" "alice" "item_count" 3}) - (bindings (stream-chunk-bindings chunk))) - ;; Keys with underscores need normalizing for SX env - (assert-equal "alice" (get bindings "user_name")) - ;; normalize-binding-key converts them - (assert-equal "user-name" (normalize-binding-key "user_name")) - (assert-equal "item-count" (normalize-binding-key "item_count")))) - - (deftest "defpage stream flag defaults to false" - (let ((p (defpage test-no-stream :path "/ns" :auth :public :content (div "x")))) - (assert-equal false (get p "stream")))) - - (deftest "defpage stream true recorded in page-def" - (let ((p (defpage test-with-stream :path "/ws" :auth :public - :stream true - :shell (~layout (~suspense :id "data")) - :content (~chunk :val val)))) - (assert-equal true (get p "stream")) - (assert-true (not (nil? (get p "shell"))))))) - -) ;; end (when has-server-forms?) diff --git a/spec/types.sx b/spec/types.sx index 9ed0073..5f71576 100644 --- a/spec/types.sx +++ b/spec/types.sx @@ -4,10 +4,13 @@ ;; Registration-time type checking: zero runtime cost. ;; Annotations are optional — unannotated code defaults to `any`. ;; -;; Depends on: eval.sx (type-of, component accessors, env ops) +;; This is an optional spec module — NOT part of the core evaluator. +;; It registers deftype and defeffect via register-special-form! at load time. +;; +;; Depends on: evaluator.sx (type-of, component accessors, env ops) ;; primitives.sx, boundary.sx (return type declarations) ;; -;; Platform interface (from eval.sx, already provided): +;; Platform interface (from evaluator.sx, already provided): ;; (type-of x) → type string ;; (symbol-name s) → string ;; (keyword-name k) → string @@ -22,6 +25,88 @@ ;; ========================================================================== +;; -------------------------------------------------------------------------- +;; 0. Definition forms — deftype and defeffect +;; -------------------------------------------------------------------------- +;; These were previously in evaluator.sx. Now they live here and register +;; themselves via the custom special form mechanism. + +(define make-type-def + (fn ((name :as string) (params :as list) body) + {:name name :params params :body body})) + +(define normalize-type-body + (fn (body) + ;; Convert AST type expressions to type representation. + ;; Symbols → strings, (union ...) → (or ...), dict keys → strings. + (cond + (nil? body) "nil" + (= (type-of body) "symbol") + (symbol-name body) + (= (type-of body) "string") + body + (= (type-of body) "keyword") + (keyword-name body) + (= (type-of body) "dict") + ;; Record type — normalize values + (map-dict (fn (k v) (normalize-type-body v)) body) + (= (type-of body) "list") + (if (empty? body) "any" + (let ((head (first body))) + (let ((head-name (if (= (type-of head) "symbol") + (symbol-name head) (str head)))) + ;; (union a b) → (or a b) + (if (= head-name "union") + (cons "or" (map normalize-type-body (rest body))) + ;; (or a b), (list-of t), (-> ...) etc. + (cons head-name (map normalize-type-body (rest body))))))) + :else (str body)))) + +(define sf-deftype + (fn ((args :as list) (env :as dict)) + ;; (deftype name body) or (deftype (name a b ...) body) + (let ((name-or-form (first args)) + (body-expr (nth args 1)) + (type-name nil) + (type-params (list))) + ;; Parse name — symbol or (symbol params...) + (if (= (type-of name-or-form) "symbol") + (set! type-name (symbol-name name-or-form)) + (when (= (type-of name-or-form) "list") + (set! type-name (symbol-name (first name-or-form))) + (set! type-params + (map (fn (p) (if (= (type-of p) "symbol") + (symbol-name p) (str p))) + (rest name-or-form))))) + ;; Normalize and store in *type-registry* + (let ((body (normalize-type-body body-expr)) + (registry (if (env-has? env "*type-registry*") + (env-get env "*type-registry*") + (dict)))) + (dict-set! registry type-name + (make-type-def type-name type-params body)) + (env-bind! env "*type-registry*" registry) + nil)))) + +(define sf-defeffect + (fn ((args :as list) (env :as dict)) + ;; (defeffect name) — register an effect name + (let ((effect-name (if (= (type-of (first args)) "symbol") + (symbol-name (first args)) + (str (first args)))) + (registry (if (env-has? env "*effect-registry*") + (env-get env "*effect-registry*") + (list)))) + (when (not (contains? registry effect-name)) + (append! registry effect-name)) + (env-bind! env "*effect-registry*" registry) + nil))) + +;; Register as custom special forms +(register-special-form! "deftype" sf-deftype) +(register-special-form! "defeffect" sf-defeffect) + + ;; -------------------------------------------------------------------------- ;; 1. Type representation ;; -------------------------------------------------------------------------- diff --git a/sx/sx/plans/foundations.sx b/sx/sx/plans/foundations.sx index 334b458..682e830 100644 --- a/sx/sx/plans/foundations.sx +++ b/sx/sx/plans/foundations.sx @@ -234,6 +234,9 @@ (tr (td :class "pr-4 py-1" "3.5") (td :class "pr-4" "Data representations") (td :class "text-stone-400" "Planned — byte buffers + typed structs")) + (tr (td :class "pr-4 py-1" "3.7") + (td :class "pr-4" "Verified components") + (td :class "text-stone-400" "Planned — content-addressed UI trust")) (tr (td :class "pr-4 py-1" "4") (td :class "pr-4" "Concurrent CEK") (td :class "text-amber-600 font-semibold" "Spec complete — implementation next")) @@ -358,6 +361,143 @@ "A " (code "defstruct") " declaration is a type definition that the type checker can verify " "and the compiler can exploit. On interpreted hosts, the same code runs — just slower.") + ;; ----------------------------------------------------------------------- + ;; Step 3.7: Verified Components + ;; ----------------------------------------------------------------------- + + (h2 :class "text-xl font-bold mt-12 mb-4" "Step 3.7: Verified Components") + + (p "Content-addressed components become a trust mechanism. " + "HTTPS tells you the connection is authentic. " + "Verified components tell you the " (em "UI") " is authentic — " + "that the payment form in your browser is the exact component that was audited, " + "not a tampered copy injected by XSS, a rogue extension, or a compromised CDN.") + + (h3 :class "text-lg font-semibold mt-8 mb-3" "Why SX can do this") + + (p "Most frameworks can't verify UI at the component level because there's no stable identity. " + "A React component is compiled, bundled, minified, tree-shaken — " + "the thing in the browser bears no relationship to the source. In SX:") + + (ul :class "list-disc pl-6 mb-4 space-y-1" + (li (strong "Components are source") " — the " (code ".sx") " definition IS the component. No compilation step that could diverge.") + (li (strong "Components are pure functions") " — same inputs, same output. Deterministic.") + (li (strong "Content addressing is built in") " — " (code "freeze-to-cid") " gives every component a CID (Step 3).") + (li (strong "The evaluator runs in the browser") " — the client can independently compute the CID of any component it receives.")) + + (p "Because components are pure functions defined in source form, " + "verifying the definition IS verifying the behaviour. " + "There is no gap between \"what was audited\" and \"what runs.\" " + "That gap is where every UI supply chain attack lives.") + + (h3 :class "text-lg font-semibold mt-8 mb-3" "3.7a Transitive closure CID") + + (p "A component's CID must cover its entire dependency tree. " + "If " (code "~bank/payment-form") " calls " (code "~bank/amount-input") " calls " + (code "~ui/text-field") ", all three definitions are part of the CID:") + + (~docs/code :code + (str ";; Shallow CID — just this component's definition\n" + "(freeze-to-cid ~bank/payment-form) ;; => bafyrei..abc\n" + "\n" + ";; Deep CID — component + all transitive dependencies\n" + "(freeze-to-cid-deep ~bank/payment-form) ;; => bafyrei..xyz\n" + "\n" + ";; The deep CID changes if ANY dependency changes.\n" + ";; A one-character change in ~ui/text-field\n" + ";; produces a completely different deep CID.")) + + (h3 :class "text-lg font-semibold mt-8 mb-3" "3.7b Canonical serialization") + + (p "For CIDs to match across hosts, the serialized form must be identical. " + "Canonical SX: no comments, no redundant whitespace, deterministic key ordering in dicts, " + "normalized number representation:") + + (~docs/code :code + (str ";; These must produce the same CID on JS, Python, and OCaml:\n" + "(canonical-sx '(div :class \"card\" (p \"hello\")))\n" + ";; => \"(div :class \\\"card\\\" (p \\\"hello\\\"))\"\n" + "\n" + ";; Dict key ordering is sorted:\n" + "(canonical-sx '{:b 2 :a 1}) ;; => \"{:a 1 :b 2}\"")) + + (h3 :class "text-lg font-semibold mt-8 mb-3" "3.7c Browser verification") + + (p "The client-side verification flow:") + + (~docs/code :code + (str ";; Server sends component + CID via aser wire format\n" + ";; Browser receives, independently computes CID, compares\n" + "\n" + ";; Per-component verification\n" + "(component-verify ~bank/payment-form\n" + " :expected-cid \"bafyrei...\"\n" + " :on-mismatch :refuse) ;; or :warn, :log\n" + "\n" + ";; Verify entire page component tree against published manifest\n" + "(page-verify\n" + " :manifest-url \"/.well-known/sx-manifest.json\"\n" + " :on-mismatch :refuse)\n" + "\n" + ";; Query verification status (for UI indicators)\n" + "(verified? ~bank/payment-form) ;; => true/false")) + + (p "Visual indicator — like the HTTPS lock icon, but for individual UI components. " + "The browser knows which components have verified CIDs and can surface this to the user.") + + (h3 :class "text-lg font-semibold mt-8 mb-3" "3.7d Manifest and discovery") + + (p "Publishers declare expected CIDs via a well-known manifest:") + + (~docs/code :code + (str ";; .well-known/sx-manifest.json\n" + "{\"version\": 1,\n" + " \"components\": {\n" + " \"~bank/payment-form\": {\n" + " \"cid\": \"bafyrei...abc\",\n" + " \"cid-deep\": \"bafyrei...xyz\",\n" + " \"audited\": \"2026-03-01\",\n" + " \"auditor\": \"security-firm.com\"\n" + " },\n" + " \"~bank/login\": {\n" + " \"cid\": \"bafyrei...def\",\n" + " \"cid-deep\": \"bafyrei...uvw\",\n" + " \"audited\": \"2026-02-15\"\n" + " }\n" + " },\n" + " \"signature\": \"...\"\n" + "}")) + + (p "Alternative discovery mechanisms:") + + (ul :class "list-disc pl-6 mb-4 space-y-1" + (li (strong "DNS TXT") " — " (code "_sx-verify.bank.com TXT \"payment-form=bafyrei...\"")) + (li (strong "Certificate transparency") " — append-only log of component CIDs, publicly auditable") + (li (strong "IPFS") " — the CID is the address; fetching from IPFS is self-verifying") + (li (strong "Signed manifest") " — publisher signs the manifest with their TLS key; browser verifies signature")) + + (h3 :class "text-lg font-semibold mt-8 mb-3" "How this differs from SRI") + + (p "Subresource Integrity (SRI) already does hash verification for " (code "