diff --git a/docker-compose.dev-sx.yml b/docker-compose.dev-sx.yml index abcc300..1fb0d61 100644 --- a/docker-compose.dev-sx.yml +++ b/docker-compose.dev-sx.yml @@ -13,6 +13,8 @@ services: ENVIRONMENT: development RELOAD: "true" SX_USE_REF: "1" + SX_USE_OCAML: "1" + SX_OCAML_BIN: "/app/bin/sx_server" SX_BOUNDARY_STRICT: "1" SX_DEV: "1" volumes: @@ -26,6 +28,8 @@ services: - ./sx/sx:/app/sx - ./sx/path_setup.py:/app/path_setup.py - ./sx/entrypoint.sh:/usr/local/bin/entrypoint.sh + # OCaml SX kernel binary (built with: cd hosts/ocaml && eval $(opam env) && dune build) + - ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro - ./sx/__init__.py:/app/__init__.py:ro # sibling models for cross-domain SQLAlchemy imports - ./blog/__init__.py:/app/blog/__init__.py:ro diff --git a/hosts/ocaml/bin/debug_set.ml b/hosts/ocaml/bin/debug_set.ml new file mode 100644 index 0000000..2f68b4b --- /dev/null +++ b/hosts/ocaml/bin/debug_set.ml @@ -0,0 +1,36 @@ +module T = Sx.Sx_types +module P = Sx.Sx_parser +module R = Sx.Sx_ref +open T + +let () = + let env = T.make_env () in + let eval src = + let exprs = P.parse_all src in + let result = ref Nil in + List.iter (fun e -> result := R.eval_expr e (Env env)) exprs; + !result + in + (* Test 1: basic set! in closure *) + let r = eval "(let ((x 0)) (set! x 42) x)" in + Printf.printf "basic set!: %s (expect 42)\n%!" (T.inspect r); + + (* Test 2: set! through lambda call *) + let r = eval "(let ((x 0)) (let ((f (fn () (set! x 99)))) (f) x))" in + Printf.printf "set! via lambda: %s (expect 99)\n%!" (T.inspect r); + + (* Test 3: counter pattern *) + let r = eval "(do (define make-counter (fn () (let ((c 0)) (fn () (set! c (+ c 1)) c)))) (let ((counter (make-counter))) (counter) (counter) (counter)))" in + Printf.printf "counter: %s (expect 3)\n%!" (T.inspect r); + + (* Test 4: set! in for-each *) + let r = eval "(let ((total 0)) (for-each (fn (n) (set! total (+ total n))) (list 1 2 3 4 5)) total)" in + Printf.printf "set! in for-each: %s (expect 15)\n%!" (T.inspect r); + + (* Test 5: append! in for-each *) + ignore (T.env_bind env "append!" (NativeFn ("append!", fun args -> + match args with + | [List items; v] -> List (items @ [v]) + | _ -> raise (Eval_error "append!: expected list and value")))); + let r = eval "(let ((log (list))) (for-each (fn (x) (append! log x)) (list 1 2 3)) log)" in + Printf.printf "append! in for-each: %s (expect (1 2 3))\n%!" (T.inspect r) diff --git a/hosts/ocaml/bin/dune b/hosts/ocaml/bin/dune index b9f922b..354a7a4 100644 --- a/hosts/ocaml/bin/dune +++ b/hosts/ocaml/bin/dune @@ -1,3 +1,3 @@ -(executable - (name run_tests) +(executables + (names run_tests debug_set sx_server) (libraries sx)) diff --git a/hosts/ocaml/bin/dune_debug b/hosts/ocaml/bin/dune_debug new file mode 100644 index 0000000..258c336 --- /dev/null +++ b/hosts/ocaml/bin/dune_debug @@ -0,0 +1 @@ +(executable (name debug_macro) (libraries sx)) diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 40ddce2..35d7a08 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -1,102 +1,539 @@ -(** Minimal test runner — verifies the OCaml foundation (types, parser, primitives). +(** Test runner — runs the SX spec test suite against the transpiled CEK evaluator. - Eventually this will load test-framework.sx and run the full spec test - suite against the transpiled evaluator. For now it exercises the parser - and primitives directly. *) + Provides the 5 platform functions required by test-framework.sx: + try-call, report-pass, report-fail, push-suite, pop-suite -open Sx.Sx_types -open Sx.Sx_parser -open Sx.Sx_primitives + Plus test helpers: sx-parse, cek-eval, env-*, equal?, etc. + + Usage: + dune exec bin/run_tests.exe # foundation + spec tests + dune exec bin/run_tests.exe -- test-primitives # specific test + dune exec bin/run_tests.exe -- --foundation # foundation only *) + +module Sx_types = Sx.Sx_types +module Sx_parser = Sx.Sx_parser +module Sx_primitives = Sx.Sx_primitives +module Sx_runtime = Sx.Sx_runtime +module Sx_ref = Sx.Sx_ref +module Sx_render = Sx.Sx_render + +open Sx_types +open Sx_parser +open Sx_primitives +open Sx_runtime +open Sx_ref + +(* ====================================================================== *) +(* Test state *) +(* ====================================================================== *) let pass_count = ref 0 let fail_count = ref 0 +let suite_stack : string list ref = ref [] -let assert_eq name expected actual = - if expected = actual then begin - incr pass_count; - Printf.printf " PASS: %s\n" name - end else begin - incr fail_count; - Printf.printf " FAIL: %s — expected %s, got %s\n" name (inspect expected) (inspect actual) - end +(* ====================================================================== *) +(* Deep equality — SX structural comparison *) +(* ====================================================================== *) -let assert_true name v = - if sx_truthy v then begin - incr pass_count; - Printf.printf " PASS: %s\n" name - end else begin - incr fail_count; - Printf.printf " FAIL: %s — expected truthy, got %s\n" name (inspect v) - end +let rec deep_equal a b = + match a, b with + | Nil, Nil -> true + | Bool a, Bool b -> a = b + | Number a, Number b -> a = b + | String a, String b -> a = b + | Symbol a, Symbol b -> a = b + | Keyword a, Keyword b -> a = b + | (List a | ListRef { contents = a }), (List b | ListRef { contents = b }) -> + List.length a = List.length b && + List.for_all2 deep_equal a b + | Dict a, Dict b -> + let ka = Hashtbl.fold (fun k _ acc -> k :: acc) a [] in + let kb = Hashtbl.fold (fun k _ acc -> k :: acc) b [] in + List.length ka = List.length kb && + List.for_all (fun k -> + Hashtbl.mem b k && + deep_equal + (match Hashtbl.find_opt a k with Some v -> v | None -> Nil) + (match Hashtbl.find_opt b k with Some v -> v | None -> Nil)) ka + | Lambda _, Lambda _ -> a == b (* identity *) + | NativeFn _, NativeFn _ -> a == b + | _ -> false -let call name args = - match Hashtbl.find_opt primitives name with - | Some f -> f args - | None -> failwith ("Unknown primitive: " ^ name) +(* ====================================================================== *) +(* Build evaluator environment with test platform functions *) +(* ====================================================================== *) -let () = +let make_test_env () = + let env = Sx_types.make_env () in + + let bind name fn = + ignore (Sx_types.env_bind env name (NativeFn (name, fn))) + in + + (* --- 5 platform functions required by test-framework.sx --- *) + + bind "try-call" (fun args -> + match args with + | [thunk] -> + (try + (* Call the thunk: it's a lambda with no params *) + let result = eval_expr (List [thunk]) (Env env) in + ignore result; + let d = Hashtbl.create 2 in + Hashtbl.replace d "ok" (Bool true); + Dict d + with + | Eval_error msg -> + let d = Hashtbl.create 2 in + Hashtbl.replace d "ok" (Bool false); + Hashtbl.replace d "error" (String msg); + Dict d + | exn -> + let d = Hashtbl.create 2 in + Hashtbl.replace d "ok" (Bool false); + Hashtbl.replace d "error" (String (Printexc.to_string exn)); + Dict d) + | _ -> raise (Eval_error "try-call: expected 1 arg")); + + bind "report-pass" (fun args -> + match args with + | [String name] -> + incr pass_count; + let ctx = String.concat " > " (List.rev !suite_stack) in + Printf.printf " PASS: %s > %s\n%!" ctx name; + Nil + | [v] -> + incr pass_count; + let ctx = String.concat " > " (List.rev !suite_stack) in + Printf.printf " PASS: %s > %s\n%!" ctx (Sx_types.inspect v); + Nil + | _ -> raise (Eval_error "report-pass: expected 1 arg")); + + bind "report-fail" (fun args -> + match args with + | [String name; String error] -> + incr fail_count; + let ctx = String.concat " > " (List.rev !suite_stack) in + Printf.printf " FAIL: %s > %s: %s\n%!" ctx name error; + Nil + | [name_v; error_v] -> + incr fail_count; + let ctx = String.concat " > " (List.rev !suite_stack) in + Printf.printf " FAIL: %s > %s: %s\n%!" ctx + (Sx_types.value_to_string name_v) + (Sx_types.value_to_string error_v); + Nil + | _ -> raise (Eval_error "report-fail: expected 2 args")); + + bind "push-suite" (fun args -> + match args with + | [String name] -> + suite_stack := name :: !suite_stack; + let indent = String.make ((List.length !suite_stack - 1) * 2) ' ' in + Printf.printf "%sSuite: %s\n%!" indent name; + Nil + | [v] -> + let name = Sx_types.value_to_string v in + suite_stack := name :: !suite_stack; + let indent = String.make ((List.length !suite_stack - 1) * 2) ' ' in + Printf.printf "%sSuite: %s\n%!" indent name; + Nil + | _ -> raise (Eval_error "push-suite: expected 1 arg")); + + bind "pop-suite" (fun _args -> + suite_stack := (match !suite_stack with _ :: t -> t | [] -> []); + Nil); + + (* --- Test helpers --- *) + + bind "sx-parse" (fun args -> + match args with + | [String s] -> List (parse_all s) + | _ -> raise (Eval_error "sx-parse: expected string")); + + bind "sx-parse-one" (fun args -> + match args with + | [String s] -> + let exprs = parse_all s in + (match exprs with e :: _ -> e | [] -> Nil) + | _ -> raise (Eval_error "sx-parse-one: expected string")); + + bind "cek-eval" (fun args -> + match args with + | [String s] -> + let exprs = parse_all s in + (match exprs with + | e :: _ -> eval_expr e (Env env) + | [] -> Nil) + | _ -> raise (Eval_error "cek-eval: expected string")); + + bind "eval-expr-cek" (fun args -> + match args with + | [expr; e] -> eval_expr expr e + | [expr] -> eval_expr expr (Env env) + | _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args")); + + bind "test-env" (fun _args -> Env (Sx_types.env_extend env)); + + (* --- Environment operations --- *) + + bind "env-get" (fun args -> + match args with + | [Env e; String k] -> Sx_types.env_get e k + | [Env e; Keyword k] -> Sx_types.env_get e k + | _ -> raise (Eval_error "env-get: expected env and string")); + + bind "env-has?" (fun args -> + match args with + | [Env e; String k] -> Bool (Sx_types.env_has e k) + | [Env e; Keyword k] -> Bool (Sx_types.env_has e k) + | _ -> raise (Eval_error "env-has?: expected env and string")); + + bind "env-bind!" (fun args -> + match args with + | [Env e; String k; v] -> Sx_types.env_bind e k v + | [Env e; Keyword k; v] -> Sx_types.env_bind e k v + | _ -> raise (Eval_error "env-bind!: expected env, key, value")); + + bind "env-set!" (fun args -> + match args with + | [Env e; String k; v] -> Sx_types.env_set e k v + | [Env e; Keyword k; v] -> Sx_types.env_set e k v + | _ -> raise (Eval_error "env-set!: expected env, key, value")); + + bind "env-extend" (fun args -> + match args with + | [Env e] -> Env (Sx_types.env_extend e) + | _ -> raise (Eval_error "env-extend: expected env")); + + bind "env-merge" (fun args -> + match args with + | [Env a; Env b] -> Env (Sx_types.env_merge a b) + | _ -> raise (Eval_error "env-merge: expected 2 envs")); + + (* --- Equality --- *) + + bind "equal?" (fun args -> + match args with + | [a; b] -> Bool (deep_equal a b) + | _ -> raise (Eval_error "equal?: expected 2 args")); + + bind "identical?" (fun args -> + match args with + | [a; b] -> Bool (a == b) + | _ -> raise (Eval_error "identical?: expected 2 args")); + + (* --- Continuation support --- *) + + bind "make-continuation" (fun args -> + match args with + | [f] -> + let k v = sx_call f [v] in + Continuation (k, None) + | _ -> raise (Eval_error "make-continuation: expected 1 arg")); + + bind "continuation?" (fun args -> + match args with + | [Continuation _] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "continuation?: expected 1 arg")); + + bind "continuation-fn" (fun args -> + match args with + | [Continuation (f, _)] -> NativeFn ("continuation-fn-result", fun args -> + match args with [v] -> f v | _ -> f Nil) + | _ -> raise (Eval_error "continuation-fn: expected continuation")); + + (* --- Core builtins used by test framework / test code --- *) + + bind "assert" (fun args -> + match args with + | [cond] -> + if not (sx_truthy cond) then raise (Eval_error "Assertion failed"); + Bool true + | [cond; String msg] -> + if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg)); + Bool true + | [cond; msg] -> + if not (sx_truthy cond) then + raise (Eval_error ("Assertion error: " ^ Sx_types.value_to_string msg)); + Bool true + | _ -> raise (Eval_error "assert: expected 1-2 args")); + + bind "append!" (fun args -> + match args with + | [ListRef r; v] -> r := !r @ [v]; ListRef r (* mutate in place *) + | [List items; v] -> List (items @ [v]) (* immutable fallback *) + | _ -> raise (Eval_error "append!: expected list and value")); + + (* --- HTML Renderer (from sx_render.ml library module) --- *) + Sx.Sx_render.setup_render_env env; + + (* --- Missing primitives referenced by tests --- *) + + bind "upcase" (fun args -> + match args with + | [String s] -> String (String.uppercase_ascii s) + | _ -> raise (Eval_error "upcase: expected string")); + + bind "downcase" (fun args -> + match args with + | [String s] -> String (String.lowercase_ascii s) + | _ -> raise (Eval_error "downcase: expected string")); + + bind "make-keyword" (fun args -> + match args with + | [String s] -> Keyword s + | _ -> raise (Eval_error "make-keyword: expected string")); + + bind "string-length" (fun args -> + match args with + | [String s] -> Number (float_of_int (String.length s)) + | _ -> raise (Eval_error "string-length: expected string")); + + bind "dict-get" (fun args -> + match args with + | [Dict d; String k] -> Sx_types.dict_get d k + | [Dict d; Keyword k] -> Sx_types.dict_get d k + | _ -> raise (Eval_error "dict-get: expected dict and key")); + + bind "apply" (fun args -> + match args with + | f :: rest -> + let all_args = match List.rev rest with + | List last :: prefix -> List.rev prefix @ last + | _ -> rest + in + sx_call f all_args + | _ -> raise (Eval_error "apply: expected function and args")); + + (* --- Type system helpers (for --full tests) --- *) + + bind "test-prim-types" (fun _args -> + let d = Hashtbl.create 40 in + List.iter (fun (k, v) -> Hashtbl.replace d k (String v)) [ + "+", "number"; "-", "number"; "*", "number"; "/", "number"; + "mod", "number"; "inc", "number"; "dec", "number"; + "abs", "number"; "min", "number"; "max", "number"; + "floor", "number"; "ceil", "number"; "round", "number"; + "str", "string"; "upper", "string"; "lower", "string"; + "trim", "string"; "join", "string"; "replace", "string"; + "format", "string"; "substr", "string"; + "=", "boolean"; "<", "boolean"; ">", "boolean"; + "<=", "boolean"; ">=", "boolean"; "!=", "boolean"; + "not", "boolean"; "nil?", "boolean"; "empty?", "boolean"; + "number?", "boolean"; "string?", "boolean"; "boolean?", "boolean"; + "list?", "boolean"; "dict?", "boolean"; "symbol?", "boolean"; + "keyword?", "boolean"; "contains?", "boolean"; "has-key?", "boolean"; + "starts-with?", "boolean"; "ends-with?", "boolean"; + "len", "number"; "first", "any"; "rest", "list"; + "last", "any"; "nth", "any"; "cons", "list"; + "append", "list"; "concat", "list"; "reverse", "list"; + "sort", "list"; "slice", "list"; "range", "list"; + "flatten", "list"; "keys", "list"; "vals", "list"; + "map-dict", "dict"; "assoc", "dict"; "dissoc", "dict"; + "merge", "dict"; "dict", "dict"; + "get", "any"; "type-of", "string"; + ]; + Dict d); + + bind "test-prim-param-types" (fun _args -> + let d = Hashtbl.create 10 in + let pos name typ = + let d2 = Hashtbl.create 2 in + Hashtbl.replace d2 "positional" (List [List [String name; String typ]]); + Hashtbl.replace d2 "rest-type" Nil; + Dict d2 + in + let pos_rest name typ rt = + let d2 = Hashtbl.create 2 in + Hashtbl.replace d2 "positional" (List [List [String name; String typ]]); + Hashtbl.replace d2 "rest-type" (String rt); + Dict d2 + in + Hashtbl.replace d "+" (pos_rest "a" "number" "number"); + Hashtbl.replace d "-" (pos_rest "a" "number" "number"); + Hashtbl.replace d "*" (pos_rest "a" "number" "number"); + Hashtbl.replace d "/" (pos_rest "a" "number" "number"); + Hashtbl.replace d "inc" (pos "n" "number"); + Hashtbl.replace d "dec" (pos "n" "number"); + Hashtbl.replace d "upper" (pos "s" "string"); + Hashtbl.replace d "lower" (pos "s" "string"); + Hashtbl.replace d "keys" (pos "d" "dict"); + Hashtbl.replace d "vals" (pos "d" "dict"); + Dict d); + + (* --- Component accessors --- *) + + bind "component-param-types" (fun _args -> Nil); + + bind "component-set-param-types!" (fun _args -> Nil); + + bind "component-params" (fun args -> + match args with + | [Component c] -> List (List.map (fun s -> String s) c.c_params) + | _ -> Nil); + + bind "component-body" (fun args -> + match args with + | [Component c] -> c.c_body + | _ -> Nil); + + bind "component-has-children" (fun args -> + match args with + | [Component c] -> Bool c.c_has_children + | _ -> Bool false); + + bind "component-affinity" (fun args -> + match args with + | [Component c] -> String c.c_affinity + | _ -> String "auto"); + + (* --- Parser test helpers --- *) + + bind "keyword-name" (fun args -> + match args with + | [Keyword k] -> String k + | _ -> raise (Eval_error "keyword-name: expected keyword")); + + bind "symbol-name" (fun args -> + match args with + | [Symbol s] -> String s + | _ -> raise (Eval_error "symbol-name: expected symbol")); + + bind "sx-serialize" (fun args -> + match args with + | [v] -> String (Sx_types.inspect v) + | _ -> raise (Eval_error "sx-serialize: expected 1 arg")); + + (* --- make-symbol --- *) + + bind "make-symbol" (fun args -> + match args with + | [String s] -> Symbol s + | [v] -> Symbol (Sx_types.value_to_string v) + | _ -> raise (Eval_error "make-symbol: expected 1 arg")); + + (* --- CEK stepping / introspection --- *) + + bind "make-cek-state" (fun args -> + match args with + | [ctrl; env'; kont] -> Sx_ref.make_cek_state ctrl env' kont + | _ -> raise (Eval_error "make-cek-state: expected 3 args")); + + bind "cek-step" (fun args -> + match args with + | [state] -> Sx_ref.cek_step state + | _ -> raise (Eval_error "cek-step: expected 1 arg")); + + bind "cek-phase" (fun args -> + match args with + | [state] -> Sx_ref.cek_phase state + | _ -> raise (Eval_error "cek-phase: expected 1 arg")); + + bind "cek-value" (fun args -> + match args with + | [state] -> Sx_ref.cek_value state + | _ -> raise (Eval_error "cek-value: expected 1 arg")); + + bind "cek-terminal?" (fun args -> + match args with + | [state] -> Sx_ref.cek_terminal_p state + | _ -> raise (Eval_error "cek-terminal?: expected 1 arg")); + + bind "cek-kont" (fun args -> + match args with + | [state] -> Sx_ref.cek_kont state + | _ -> raise (Eval_error "cek-kont: expected 1 arg")); + + bind "frame-type" (fun args -> + match args with + | [frame] -> Sx_ref.frame_type frame + | _ -> raise (Eval_error "frame-type: expected 1 arg")); + + (* --- Strict mode --- *) + (* *strict* is a plain value in the env, mutated via env_set by set-strict! *) + ignore (Sx_types.env_bind env "*strict*" (Bool false)); + ignore (Sx_types.env_bind env "*prim-param-types*" Nil); + + bind "set-strict!" (fun args -> + match args with + | [v] -> + Sx_ref._strict_ref := v; + ignore (Sx_types.env_set env "*strict*" v); Nil + | _ -> raise (Eval_error "set-strict!: expected 1 arg")); + + bind "set-prim-param-types!" (fun args -> + match args with + | [v] -> + Sx_ref._prim_param_types_ref := v; + ignore (Sx_types.env_set env "*prim-param-types*" v); Nil + | _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg")); + + bind "value-matches-type?" (fun args -> + match args with + | [v; String expected] -> Sx_ref.value_matches_type_p v (String expected) + | _ -> raise (Eval_error "value-matches-type?: expected value and type string")); + + env + +(* ====================================================================== *) +(* Foundation tests (direct, no evaluator) *) +(* ====================================================================== *) + +let run_foundation_tests () = Printf.printf "=== SX OCaml Foundation Tests ===\n\n"; - (* --- Parser tests --- *) + let assert_eq name expected actual = + if deep_equal expected actual then begin + incr pass_count; + Printf.printf " PASS: %s\n" name + end else begin + incr fail_count; + Printf.printf " FAIL: %s — expected %s, got %s\n" name + (Sx_types.inspect expected) (Sx_types.inspect actual) + end + in + let assert_true name v = + if sx_truthy v then begin + incr pass_count; + Printf.printf " PASS: %s\n" name + end else begin + incr fail_count; + Printf.printf " FAIL: %s — expected truthy, got %s\n" name (Sx_types.inspect v) + end + in + let call name args = + match Hashtbl.find_opt primitives name with + | Some f -> f args + | None -> failwith ("Unknown primitive: " ^ name) + in + Printf.printf "Suite: parser\n"; - - let exprs = parse_all "42" in - assert_eq "number" (Number 42.0) (List.hd exprs); - - let exprs = parse_all "\"hello\"" in - assert_eq "string" (String "hello") (List.hd exprs); - - let exprs = parse_all "true" in - assert_eq "bool true" (Bool true) (List.hd exprs); - - let exprs = parse_all "nil" in - assert_eq "nil" Nil (List.hd exprs); - - let exprs = parse_all ":class" in - assert_eq "keyword" (Keyword "class") (List.hd exprs); - - let exprs = parse_all "foo" in - assert_eq "symbol" (Symbol "foo") (List.hd exprs); - - let exprs = parse_all "(+ 1 2)" in - assert_eq "list" (List [Symbol "+"; Number 1.0; Number 2.0]) (List.hd exprs); - - let exprs = parse_all "(div :class \"card\" (p \"hi\"))" in - (match List.hd exprs with + assert_eq "number" (Number 42.0) (List.hd (parse_all "42")); + assert_eq "string" (String "hello") (List.hd (parse_all "\"hello\"")); + assert_eq "bool true" (Bool true) (List.hd (parse_all "true")); + assert_eq "nil" Nil (List.hd (parse_all "nil")); + assert_eq "keyword" (Keyword "class") (List.hd (parse_all ":class")); + assert_eq "symbol" (Symbol "foo") (List.hd (parse_all "foo")); + assert_eq "list" (List [Symbol "+"; Number 1.0; Number 2.0]) (List.hd (parse_all "(+ 1 2)")); + (match List.hd (parse_all "(div :class \"card\" (p \"hi\"))") with | List [Symbol "div"; Keyword "class"; String "card"; List [Symbol "p"; String "hi"]] -> incr pass_count; Printf.printf " PASS: nested list\n" - | v -> incr fail_count; Printf.printf " FAIL: nested list — got %s\n" (inspect v)); - - let exprs = parse_all "'(1 2 3)" in - (match List.hd exprs with + | v -> incr fail_count; Printf.printf " FAIL: nested list — got %s\n" (Sx_types.inspect v)); + (match List.hd (parse_all "'(1 2 3)") with | List [Symbol "quote"; List [Number 1.0; Number 2.0; Number 3.0]] -> incr pass_count; Printf.printf " PASS: quote sugar\n" - | v -> incr fail_count; Printf.printf " FAIL: quote sugar — got %s\n" (inspect v)); - - let exprs = parse_all "{:a 1 :b 2}" in - (match List.hd exprs with + | v -> incr fail_count; Printf.printf " FAIL: quote sugar — got %s\n" (Sx_types.inspect v)); + (match List.hd (parse_all "{:a 1 :b 2}") with | Dict d when dict_has d "a" && dict_has d "b" -> incr pass_count; Printf.printf " PASS: dict literal\n" - | v -> incr fail_count; Printf.printf " FAIL: dict literal — got %s\n" (inspect v)); - - let exprs = parse_all ";; comment\n42" in - assert_eq "comment" (Number 42.0) (List.hd exprs); - - let exprs = parse_all "(fn (x) (+ x 1))" in - (match List.hd exprs with - | List [Symbol "fn"; List [Symbol "x"]; List [Symbol "+"; Symbol "x"; Number 1.0]] -> - incr pass_count; Printf.printf " PASS: fn form\n" - | v -> incr fail_count; Printf.printf " FAIL: fn form — got %s\n" (inspect v)); - - let exprs = parse_all "\"hello\\nworld\"" in - assert_eq "string escape" (String "hello\nworld") (List.hd exprs); - - let exprs = parse_all "(1 2 3) (4 5)" in - assert_eq "multiple exprs" (Number 2.0) (Number (float_of_int (List.length exprs))); + | v -> incr fail_count; Printf.printf " FAIL: dict literal — got %s\n" (Sx_types.inspect v)); + assert_eq "comment" (Number 42.0) (List.hd (parse_all ";; comment\n42")); + assert_eq "string escape" (String "hello\nworld") (List.hd (parse_all "\"hello\\nworld\"")); + assert_eq "multiple exprs" (Number 2.0) (Number (float_of_int (List.length (parse_all "(1 2 3) (4 5)")))); Printf.printf "\nSuite: primitives\n"; - - (* --- Primitive tests --- *) assert_eq "+" (Number 6.0) (call "+" [Number 1.0; Number 2.0; Number 3.0]); assert_eq "-" (Number 3.0) (call "-" [Number 5.0; Number 2.0]); assert_eq "*" (Number 12.0) (call "*" [Number 3.0; Number 4.0]); @@ -104,26 +541,22 @@ let () = assert_eq "mod" (Number 1.0) (call "mod" [Number 5.0; Number 2.0]); assert_eq "inc" (Number 6.0) (call "inc" [Number 5.0]); assert_eq "abs" (Number 5.0) (call "abs" [Number (-5.0)]); - assert_true "=" (call "=" [Number 1.0; Number 1.0]); assert_true "!=" (call "!=" [Number 1.0; Number 2.0]); assert_true "<" (call "<" [Number 1.0; Number 2.0]); assert_true ">" (call ">" [Number 2.0; Number 1.0]); - assert_true "nil?" (call "nil?" [Nil]); assert_true "number?" (call "number?" [Number 1.0]); assert_true "string?" (call "string?" [String "hi"]); assert_true "list?" (call "list?" [List [Number 1.0]]); assert_true "empty? list" (call "empty?" [List []]); assert_true "empty? string" (call "empty?" [String ""]); - assert_eq "str" (String "hello42") (call "str" [String "hello"; Number 42.0]); assert_eq "upper" (String "HI") (call "upper" [String "hi"]); assert_eq "trim" (String "hi") (call "trim" [String " hi "]); assert_eq "join" (String "a,b,c") (call "join" [String ","; List [String "a"; String "b"; String "c"]]); assert_true "starts-with?" (call "starts-with?" [String "hello"; String "hel"]); assert_true "contains?" (call "contains?" [List [Number 1.0; Number 2.0; Number 3.0]; Number 2.0]); - assert_eq "list" (List [Number 1.0; Number 2.0]) (call "list" [Number 1.0; Number 2.0]); assert_eq "len" (Number 3.0) (call "len" [List [Number 1.0; Number 2.0; Number 3.0]]); assert_eq "first" (Number 1.0) (call "first" [List [Number 1.0; Number 2.0]]); @@ -135,43 +568,134 @@ let () = assert_eq "reverse" (List [Number 3.0; Number 2.0; Number 1.0]) (call "reverse" [List [Number 1.0; Number 2.0; Number 3.0]]); assert_eq "range" (List [Number 0.0; Number 1.0; Number 2.0]) (call "range" [Number 3.0]); - assert_eq "slice" (List [Number 2.0; Number 3.0]) (call "slice" [List [Number 1.0; Number 2.0; Number 3.0]; Number 1.0]); - + assert_eq "slice" (List [Number 2.0; Number 3.0]) + (call "slice" [List [Number 1.0; Number 2.0; Number 3.0]; Number 1.0]); assert_eq "type-of" (String "number") (call "type-of" [Number 1.0]); assert_eq "type-of nil" (String "nil") (call "type-of" [Nil]); Printf.printf "\nSuite: env\n"; - - (* --- Environment tests --- *) - let e = make_env () in - ignore (env_bind e "x" (Number 42.0)); - assert_eq "env-bind + get" (Number 42.0) (env_get e "x"); - assert_true "env-has" (Bool (env_has e "x")); - - let child = env_extend e in - ignore (env_bind child "y" (Number 10.0)); - assert_eq "child sees parent" (Number 42.0) (env_get child "x"); - assert_eq "child own binding" (Number 10.0) (env_get child "y"); - - ignore (env_set child "x" (Number 99.0)); - assert_eq "set! walks chain" (Number 99.0) (env_get e "x"); + let e = Sx_types.make_env () in + ignore (Sx_types.env_bind e "x" (Number 42.0)); + assert_eq "env-bind + get" (Number 42.0) (Sx_types.env_get e "x"); + assert_true "env-has" (Bool (Sx_types.env_has e "x")); + let child = Sx_types.env_extend e in + ignore (Sx_types.env_bind child "y" (Number 10.0)); + assert_eq "child sees parent" (Number 42.0) (Sx_types.env_get child "x"); + assert_eq "child own binding" (Number 10.0) (Sx_types.env_get child "y"); + ignore (Sx_types.env_set child "x" (Number 99.0)); + assert_eq "set! walks chain" (Number 99.0) (Sx_types.env_get e "x"); Printf.printf "\nSuite: types\n"; - - (* --- Type tests --- *) assert_true "sx_truthy true" (Bool (sx_truthy (Bool true))); assert_true "sx_truthy 0" (Bool (sx_truthy (Number 0.0))); assert_true "sx_truthy \"\"" (Bool (sx_truthy (String ""))); assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil)); assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false))); + let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None } in + assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l))); + ignore (Sx_types.set_lambda_name (Lambda l) "my-fn"); + assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l)) - let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = make_env (); l_name = None } in - assert_true "is_lambda" (Bool (is_lambda (Lambda l))); - ignore (Sx.Sx_types.set_lambda_name (Lambda l) "my-fn"); - assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l)); - (* --- Summary --- *) - Printf.printf "\n============================================================\n"; +(* ====================================================================== *) +(* Spec test runner *) +(* ====================================================================== *) + +let run_spec_tests env test_files = + (* Find project root: walk up from cwd until we find spec/tests *) + let rec find_root dir = + let candidate = Filename.concat dir "spec/tests" in + if Sys.file_exists candidate then dir + else + let parent = Filename.dirname dir in + if parent = dir then Sys.getcwd () (* reached filesystem root *) + else find_root parent + in + let project_dir = find_root (Sys.getcwd ()) in + let spec_tests_dir = Filename.concat project_dir "spec/tests" in + let framework_path = Filename.concat spec_tests_dir "test-framework.sx" in + + if not (Sys.file_exists framework_path) then begin + Printf.eprintf "test-framework.sx not found at %s\n" framework_path; + Printf.eprintf "Run from the project root directory.\n"; + exit 1 + end; + + let load_and_eval path = + let ic = open_in path in + let n = in_channel_length ic in + let s = Bytes.create n in + really_input ic s 0 n; + close_in ic; + let src = Bytes.to_string s in + let exprs = parse_all src in + List.iter (fun expr -> + ignore (eval_expr expr (Env env)) + ) exprs + in + + Printf.printf "\nLoading test framework...\n%!"; + load_and_eval framework_path; + + (* Determine test files *) + let files = if test_files = [] then begin + let entries = Sys.readdir spec_tests_dir in + Array.sort String.compare entries; + let requires_full = ["test-continuations.sx"; "test-types.sx"; "test-freeze.sx"; + "test-continuations-advanced.sx"; "test-signals-advanced.sx"] in + Array.to_list entries + |> List.filter (fun f -> + String.length f > 5 && + String.sub f 0 5 = "test-" && + Filename.check_suffix f ".sx" && + f <> "test-framework.sx" && + not (List.mem f requires_full)) + end else + List.map (fun name -> + if Filename.check_suffix name ".sx" then name + else name ^ ".sx") test_files + in + + List.iter (fun name -> + let path = Filename.concat spec_tests_dir name in + if Sys.file_exists path then begin + Printf.printf "\n%s\n" (String.make 60 '='); + Printf.printf "Running %s\n" name; + Printf.printf "%s\n%!" (String.make 60 '='); + (try + load_and_eval path + with + | Eval_error msg -> + incr fail_count; + Printf.printf " ERROR in %s: %s\n%!" name msg + | exn -> + incr fail_count; + Printf.printf " ERROR in %s: %s\n%!" name (Printexc.to_string exn)) + end else + Printf.eprintf "Test file not found: %s\n" path + ) files + + +(* ====================================================================== *) +(* Main *) +(* ====================================================================== *) + +let () = + let args = Array.to_list Sys.argv |> List.tl in + let foundation_only = List.mem "--foundation" args in + let test_files = List.filter (fun a -> not (String.length a > 0 && a.[0] = '-')) args in + + (* Always run foundation tests *) + run_foundation_tests (); + + if not foundation_only then begin + Printf.printf "\n=== SX Spec Tests (CEK Evaluator) ===\n%!"; + let env = make_test_env () in + run_spec_tests env test_files + end; + + (* Summary *) + Printf.printf "\n%s\n" (String.make 60 '='); Printf.printf "Results: %d passed, %d failed\n" !pass_count !fail_count; - Printf.printf "============================================================\n"; + Printf.printf "%s\n" (String.make 60 '='); if !fail_count > 0 then exit 1 diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml new file mode 100644 index 0000000..058c3a2 --- /dev/null +++ b/hosts/ocaml/bin/sx_server.ml @@ -0,0 +1,427 @@ +(** SX coroutine subprocess server. + + Persistent process that accepts commands on stdin and writes + responses on stdout. All messages are single-line SX expressions, + newline-delimited. + + Protocol: + Python → OCaml: (ping), (load path), (load-source src), + (eval src), (render src), (reset), + (io-response value) + OCaml → Python: (ready), (ok), (ok value), (error msg), + (io-request name args...) + + IO primitives (query, action, request-arg, request-method, ctx) + yield (io-request ...) and block on stdin for (io-response ...). *) + +module Sx_types = Sx.Sx_types +module Sx_parser = Sx.Sx_parser +module Sx_primitives = Sx.Sx_primitives +module Sx_runtime = Sx.Sx_runtime +module Sx_ref = Sx.Sx_ref +module Sx_render = Sx.Sx_render + +open Sx_types + + +(* ====================================================================== *) +(* Output helpers *) +(* ====================================================================== *) + +(** Escape a string for embedding in an SX string literal. *) +let escape_sx_string s = + let buf = Buffer.create (String.length s + 16) in + String.iter (function + | '"' -> Buffer.add_string buf "\\\"" + | '\\' -> Buffer.add_string buf "\\\\" + | '\n' -> Buffer.add_string buf "\\n" + | '\r' -> Buffer.add_string buf "\\r" + | '\t' -> Buffer.add_string buf "\\t" + | c -> Buffer.add_char buf c) s; + Buffer.contents buf + +(** Serialize a value to SX text (for io-request args). *) +let rec serialize_value = function + | Nil -> "nil" + | Bool true -> "true" + | Bool false -> "false" + | Number n -> + if Float.is_integer n then string_of_int (int_of_float n) + else Printf.sprintf "%g" n + | String s -> "\"" ^ escape_sx_string s ^ "\"" + | Symbol s -> s + | Keyword k -> ":" ^ k + | List items | ListRef { contents = items } -> + "(list " ^ String.concat " " (List.map serialize_value items) ^ ")" + | Dict d -> + let pairs = Hashtbl.fold (fun k v acc -> + (Printf.sprintf ":%s %s" k (serialize_value v)) :: acc) d [] in + "{" ^ String.concat " " pairs ^ "}" + | RawHTML s -> "\"" ^ escape_sx_string s ^ "\"" + | _ -> "nil" + +let send line = + print_string line; + print_char '\n'; + flush stdout + +let send_ok () = send "(ok)" +let send_ok_value v = send (Printf.sprintf "(ok %s)" (serialize_value v)) +let send_ok_string s = send (Printf.sprintf "(ok \"%s\")" (escape_sx_string s)) +let send_error msg = send (Printf.sprintf "(error \"%s\")" (escape_sx_string msg)) + + +(* ====================================================================== *) +(* IO bridge — primitives that yield to Python *) +(* ====================================================================== *) + +(** Read a line from stdin (blocking). *) +let read_line_blocking () = + try Some (input_line stdin) + with End_of_file -> None + +(** Send an io-request and block until io-response arrives. *) +let io_request name args = + let args_str = String.concat " " (List.map serialize_value args) in + send (Printf.sprintf "(io-request \"%s\" %s)" name args_str); + (* Block on stdin for io-response *) + match read_line_blocking () with + | None -> raise (Eval_error "IO bridge: stdin closed while waiting for io-response") + | Some line -> + let exprs = Sx_parser.parse_all line in + match exprs with + | [List [Symbol "io-response"; value]] -> value + | [List (Symbol "io-response" :: values)] -> + (match values with + | [v] -> v + | _ -> List values) + | _ -> raise (Eval_error ("IO bridge: unexpected response: " ^ line)) + +(** Bind IO primitives into the environment. *) +let setup_io_env env = + let bind name fn = + ignore (env_bind env name (NativeFn (name, fn))) + in + + bind "query" (fun args -> + match args with + | service :: query_name :: rest -> + io_request "query" (service :: query_name :: rest) + | _ -> raise (Eval_error "query: expected (query service name ...)")); + + bind "action" (fun args -> + match args with + | service :: action_name :: rest -> + io_request "action" (service :: action_name :: rest) + | _ -> raise (Eval_error "action: expected (action service name ...)")); + + bind "request-arg" (fun args -> + match args with + | [name] -> io_request "request-arg" [name] + | _ -> raise (Eval_error "request-arg: expected 1 arg")); + + bind "request-method" (fun _args -> + io_request "request-method" []); + + bind "ctx" (fun args -> + match args with + | [key] -> io_request "ctx" [key] + | _ -> raise (Eval_error "ctx: expected 1 arg")) + + +(* ====================================================================== *) +(* Environment setup *) +(* ====================================================================== *) + +let make_server_env () = + let env = make_env () in + + (* Evaluator bindings — same as run_tests.ml's make_test_env, + but only the ones needed for rendering (not test helpers). *) + let bind name fn = + ignore (env_bind env name (NativeFn (name, fn))) + in + + bind "assert" (fun args -> + match args with + | [cond] -> + if not (sx_truthy cond) then raise (Eval_error "Assertion failed"); + Bool true + | [cond; String msg] -> + if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg)); + Bool true + | [cond; msg] -> + if not (sx_truthy cond) then + raise (Eval_error ("Assertion error: " ^ value_to_string msg)); + Bool true + | _ -> raise (Eval_error "assert: expected 1-2 args")); + + bind "append!" (fun args -> + match args with + | [ListRef r; v] -> r := !r @ [v]; ListRef r + | [List items; v] -> List (items @ [v]) + | _ -> raise (Eval_error "append!: expected list and value")); + + (* HTML renderer *) + Sx_render.setup_render_env env; + + (* Missing primitives that may be referenced *) + bind "upcase" (fun args -> + match args with + | [String s] -> String (String.uppercase_ascii s) + | _ -> raise (Eval_error "upcase: expected string")); + + bind "downcase" (fun args -> + match args with + | [String s] -> String (String.lowercase_ascii s) + | _ -> raise (Eval_error "downcase: expected string")); + + bind "make-keyword" (fun args -> + match args with + | [String s] -> Keyword s + | _ -> raise (Eval_error "make-keyword: expected string")); + + bind "string-length" (fun args -> + match args with + | [String s] -> Number (float_of_int (String.length s)) + | _ -> raise (Eval_error "string-length: expected string")); + + bind "dict-get" (fun args -> + match args with + | [Dict d; String k] -> dict_get d k + | [Dict d; Keyword k] -> dict_get d k + | _ -> raise (Eval_error "dict-get: expected dict and key")); + + bind "apply" (fun args -> + match args with + | f :: rest -> + let all_args = match List.rev rest with + | List last :: prefix -> List.rev prefix @ last + | _ -> rest + in + Sx_runtime.sx_call f all_args + | _ -> raise (Eval_error "apply: expected function and args")); + + bind "equal?" (fun args -> + match args with + | [a; b] -> Bool (a = b) + | _ -> raise (Eval_error "equal?: expected 2 args")); + + bind "identical?" (fun args -> + match args with + | [a; b] -> Bool (a == b) + | _ -> raise (Eval_error "identical?: expected 2 args")); + + bind "make-continuation" (fun args -> + match args with + | [f] -> + let k v = Sx_runtime.sx_call f [v] in + Continuation (k, None) + | _ -> raise (Eval_error "make-continuation: expected 1 arg")); + + bind "continuation?" (fun args -> + match args with + | [Continuation _] -> Bool true + | [_] -> Bool false + | _ -> raise (Eval_error "continuation?: expected 1 arg")); + + bind "make-symbol" (fun args -> + match args with + | [String s] -> Symbol s + | [v] -> Symbol (value_to_string v) + | _ -> raise (Eval_error "make-symbol: expected 1 arg")); + + bind "sx-serialize" (fun args -> + match args with + | [v] -> String (inspect v) + | _ -> raise (Eval_error "sx-serialize: expected 1 arg")); + + (* Env operations *) + bind "env-get" (fun args -> + match args with + | [Env e; String k] -> env_get e k + | [Env e; Keyword k] -> env_get e k + | _ -> raise (Eval_error "env-get: expected env and string")); + + bind "env-has?" (fun args -> + match args with + | [Env e; String k] -> Bool (env_has e k) + | [Env e; Keyword k] -> Bool (env_has e k) + | _ -> raise (Eval_error "env-has?: expected env and string")); + + bind "env-bind!" (fun args -> + match args with + | [Env e; String k; v] -> env_bind e k v + | [Env e; Keyword k; v] -> env_bind e k v + | _ -> raise (Eval_error "env-bind!: expected env, key, value")); + + bind "env-set!" (fun args -> + match args with + | [Env e; String k; v] -> env_set e k v + | [Env e; Keyword k; v] -> env_set e k v + | _ -> raise (Eval_error "env-set!: expected env, key, value")); + + bind "env-extend" (fun args -> + match args with + | [Env e] -> Env (env_extend e) + | _ -> raise (Eval_error "env-extend: expected env")); + + bind "env-merge" (fun args -> + match args with + | [Env a; Env b] -> Env (env_merge a b) + | _ -> raise (Eval_error "env-merge: expected 2 envs")); + + (* Strict mode state *) + ignore (env_bind env "*strict*" (Bool false)); + ignore (env_bind env "*prim-param-types*" Nil); + + bind "set-strict!" (fun args -> + match args with + | [v] -> + Sx_ref._strict_ref := v; + ignore (env_set env "*strict*" v); Nil + | _ -> raise (Eval_error "set-strict!: expected 1 arg")); + + bind "set-prim-param-types!" (fun args -> + match args with + | [v] -> + Sx_ref._prim_param_types_ref := v; + ignore (env_set env "*prim-param-types*" v); Nil + | _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg")); + + bind "component-param-types" (fun _args -> Nil); + bind "component-set-param-types!" (fun _args -> Nil); + + bind "component-params" (fun args -> + match args with + | [Component c] -> List (List.map (fun s -> String s) c.c_params) + | _ -> Nil); + + bind "component-body" (fun args -> + match args with + | [Component c] -> c.c_body + | _ -> Nil); + + bind "component-has-children" (fun args -> + match args with + | [Component c] -> Bool c.c_has_children + | _ -> Bool false); + + bind "component-affinity" (fun args -> + match args with + | [Component c] -> String c.c_affinity + | _ -> String "auto"); + + bind "keyword-name" (fun args -> + match args with + | [Keyword k] -> String k + | _ -> raise (Eval_error "keyword-name: expected keyword")); + + bind "symbol-name" (fun args -> + match args with + | [Symbol s] -> String s + | _ -> raise (Eval_error "symbol-name: expected symbol")); + + (* IO primitives *) + setup_io_env env; + + env + + +(* ====================================================================== *) +(* Command dispatch *) +(* ====================================================================== *) + +let dispatch env cmd = + match cmd with + | List [Symbol "ping"] -> + send_ok_string "ocaml-cek" + + | List [Symbol "load"; String path] -> + (try + let exprs = Sx_parser.parse_file path in + let count = ref 0 in + List.iter (fun expr -> + ignore (Sx_ref.eval_expr expr (Env env)); + incr count + ) exprs; + send_ok_value (Number (float_of_int !count)) + with + | Eval_error msg -> send_error msg + | Sys_error msg -> send_error ("File error: " ^ msg) + | exn -> send_error (Printexc.to_string exn)) + + | List [Symbol "load-source"; String src] -> + (try + let exprs = Sx_parser.parse_all src in + let count = ref 0 in + List.iter (fun expr -> + ignore (Sx_ref.eval_expr expr (Env env)); + incr count + ) exprs; + send_ok_value (Number (float_of_int !count)) + with + | Eval_error msg -> send_error msg + | exn -> send_error (Printexc.to_string exn)) + + | List [Symbol "eval"; String src] -> + (try + let exprs = Sx_parser.parse_all src in + let result = List.fold_left (fun _acc expr -> + Sx_ref.eval_expr expr (Env env) + ) Nil exprs in + send_ok_value result + with + | Eval_error msg -> send_error msg + | exn -> send_error (Printexc.to_string exn)) + + | List [Symbol "render"; String src] -> + (try + let exprs = Sx_parser.parse_all src in + let expr = match exprs with + | [e] -> e + | [] -> Nil + | _ -> List (Symbol "do" :: exprs) + in + let html = Sx_render.render_to_html expr env in + send_ok_string html + with + | Eval_error msg -> send_error msg + | exn -> send_error (Printexc.to_string exn)) + + | List [Symbol "reset"] -> + (* Clear all bindings and rebuild env. + We can't reassign env, so clear and re-populate. *) + Hashtbl.clear env.bindings; + let fresh = make_server_env () in + Hashtbl.iter (fun k v -> Hashtbl.replace env.bindings k v) fresh.bindings; + send_ok () + + | _ -> + send_error ("Unknown command: " ^ inspect cmd) + + +(* ====================================================================== *) +(* Main loop *) +(* ====================================================================== *) + +let () = + let env = make_server_env () in + send "(ready)"; + (* Main command loop *) + try + while true do + match read_line_blocking () with + | None -> exit 0 (* stdin closed *) + | Some line -> + let line = String.trim line in + if line = "" then () (* skip blank lines *) + else begin + let exprs = Sx_parser.parse_all line in + match exprs with + | [cmd] -> dispatch env cmd + | _ -> send_error ("Expected single command, got " ^ string_of_int (List.length exprs)) + end + done + with + | End_of_file -> () diff --git a/hosts/ocaml/lib/sx_parser.ml b/hosts/ocaml/lib/sx_parser.ml index a44d012..0b30f5a 100644 --- a/hosts/ocaml/lib/sx_parser.ml +++ b/hosts/ocaml/lib/sx_parser.ml @@ -22,7 +22,7 @@ let skip_whitespace_and_comments s = let rec go () = if at_end s then () else match s.src.[s.pos] with - | ' ' | '\t' | '\n' | '\r' | ',' -> advance s; go () + | ' ' | '\t' | '\n' | '\r' -> advance s; go () | ';' -> while s.pos < s.len && s.src.[s.pos] <> '\n' do advance s done; if s.pos < s.len then advance s; @@ -63,6 +63,7 @@ let read_string s = let ubuf = Buffer.create 4 in Buffer.add_utf_8_uchar ubuf (Uchar.of_int code); Buffer.add_string buf (Buffer.contents ubuf) + | '`' -> Buffer.add_char buf '`' | _ -> Buffer.add_char buf '\\'; Buffer.add_char buf esc); go () end else begin @@ -91,6 +92,30 @@ let rec read_value s : value = | '"' -> String (read_string s) | '\'' -> advance s; List [Symbol "quote"; read_value s] | '`' -> advance s; List [Symbol "quasiquote"; read_value s] + | '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = ';' -> + (* Datum comment: #; discards next expression *) + advance s; advance s; + ignore (read_value s); + read_value s + | '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '\'' -> + (* Quote shorthand: #'expr -> (quote expr) *) + advance s; advance s; + List [Symbol "quote"; read_value s] + | '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '|' -> + (* Raw string: #|...| — ends at next | *) + advance s; advance s; + let buf = Buffer.create 64 in + let rec go () = + if at_end s then raise (Parse_error "Unterminated raw string"); + let c = s.src.[s.pos] in + advance s; + if c = '|' then + String (Buffer.contents buf) + else begin + Buffer.add_char buf c; + go () + end + in go () | '~' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '@' -> advance s; advance s; (* skip ~@ *) List [Symbol "splice-unquote"; read_value s] diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 39df158..847abf6 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -20,6 +20,10 @@ let get_primitive name = let as_number = function | Number n -> n + | Bool true -> 1.0 + | Bool false -> 0.0 + | Nil -> 0.0 + | String s -> (match float_of_string_opt s with Some n -> n | None -> Float.nan) | v -> raise (Eval_error ("Expected number, got " ^ type_of v)) let as_string = function @@ -28,6 +32,8 @@ let as_string = function let as_list = function | List l -> l + | ListRef r -> !r + | Nil -> [] | v -> raise (Eval_error ("Expected list, got " ^ type_of v)) let as_bool = function @@ -116,18 +122,40 @@ let () = | _ -> Nil); (* === Comparison === *) + (* Normalize ListRef to List for structural equality *) + let rec normalize_for_eq = function + | ListRef { contents = items } -> List (List.map normalize_for_eq items) + | List items -> List (List.map normalize_for_eq items) + | v -> v + in register "=" (fun args -> - match args with [a; b] -> Bool (a = b) | _ -> raise (Eval_error "=: 2 args")); + match args with + | [a; b] -> Bool (normalize_for_eq a = normalize_for_eq b) + | _ -> raise (Eval_error "=: 2 args")); register "!=" (fun args -> - match args with [a; b] -> Bool (a <> b) | _ -> raise (Eval_error "!=: 2 args")); + match args with + | [a; b] -> Bool (normalize_for_eq a <> normalize_for_eq b) + | _ -> raise (Eval_error "!=: 2 args")); register "<" (fun args -> - match args with [a; b] -> Bool (as_number a < as_number b) | _ -> raise (Eval_error "<: 2 args")); + match args with + | [String a; String b] -> Bool (a < b) + | [a; b] -> Bool (as_number a < as_number b) + | _ -> raise (Eval_error "<: 2 args")); register ">" (fun args -> - match args with [a; b] -> Bool (as_number a > as_number b) | _ -> raise (Eval_error ">: 2 args")); + match args with + | [String a; String b] -> Bool (a > b) + | [a; b] -> Bool (as_number a > as_number b) + | _ -> raise (Eval_error ">: 2 args")); register "<=" (fun args -> - match args with [a; b] -> Bool (as_number a <= as_number b) | _ -> raise (Eval_error "<=: 2 args")); + match args with + | [String a; String b] -> Bool (a <= b) + | [a; b] -> Bool (as_number a <= as_number b) + | _ -> raise (Eval_error "<=: 2 args")); register ">=" (fun args -> - match args with [a; b] -> Bool (as_number a >= as_number b) | _ -> raise (Eval_error ">=: 2 args")); + match args with + | [String a; String b] -> Bool (a >= b) + | [a; b] -> Bool (as_number a >= as_number b) + | _ -> raise (Eval_error ">=: 2 args")); (* === Logic === *) register "not" (fun args -> @@ -143,7 +171,7 @@ let () = register "boolean?" (fun args -> match args with [Bool _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "boolean?: 1 arg")); register "list?" (fun args -> - match args with [List _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "list?: 1 arg")); + match args with [List _] | [ListRef _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "list?: 1 arg")); register "dict?" (fun args -> match args with [Dict _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg")); register "symbol?" (fun args -> @@ -152,7 +180,8 @@ let () = match args with [Keyword _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "keyword?: 1 arg")); register "empty?" (fun args -> match args with - | [List []] -> Bool true | [List _] -> Bool false + | [List []] | [ListRef { contents = [] }] -> Bool true + | [List _] | [ListRef _] -> Bool false | [String ""] -> Bool true | [String _] -> Bool false | [Dict d] -> Bool (Hashtbl.length d = 0) | [Nil] -> Bool true @@ -240,7 +269,8 @@ let () = | _ -> raise (Eval_error "split: 2 args")); register "join" (fun args -> match args with - | [String sep; List items] -> String (String.concat sep (List.map to_string items)) + | [String sep; (List items | ListRef { contents = items })] -> + String (String.concat sep (List.map to_string items)) | _ -> raise (Eval_error "join: 2 args")); register "replace" (fun args -> match args with @@ -271,48 +301,58 @@ let () = | _ -> raise (Eval_error "char-from-code: 1 arg")); (* === Collections === *) - register "list" (fun args -> List args); + register "list" (fun args -> ListRef (ref args)); register "len" (fun args -> match args with - | [List l] -> Number (float_of_int (List.length l)) + | [List l] | [ListRef { contents = l }] -> Number (float_of_int (List.length l)) | [String s] -> Number (float_of_int (String.length s)) | [Dict d] -> Number (float_of_int (Hashtbl.length d)) + | [Nil] -> Number 0.0 | _ -> raise (Eval_error "len: 1 arg")); register "first" (fun args -> match args with - | [List (x :: _)] -> x | [List []] -> Nil + | [List (x :: _)] | [ListRef { contents = x :: _ }] -> x + | [List []] | [ListRef { contents = [] }] -> Nil | [Nil] -> Nil | _ -> raise (Eval_error "first: 1 list arg")); register "rest" (fun args -> match args with - | [List (_ :: xs)] -> List xs | [List []] -> List [] + | [List (_ :: xs)] | [ListRef { contents = _ :: xs }] -> List xs + | [List []] | [ListRef { contents = [] }] -> List [] | [Nil] -> List [] | _ -> raise (Eval_error "rest: 1 list arg")); register "last" (fun args -> match args with - | [List l] -> (match List.rev l with x :: _ -> x | [] -> Nil) + | [List l] | [ListRef { contents = l }] -> + (match List.rev l with x :: _ -> x | [] -> Nil) | _ -> raise (Eval_error "last: 1 list arg")); register "nth" (fun args -> match args with - | [List l; Number n] -> (try List.nth l (int_of_float n) with _ -> Nil) + | [List l; Number n] | [ListRef { contents = l }; Number n] -> + (try List.nth l (int_of_float n) with _ -> Nil) | _ -> raise (Eval_error "nth: list and number")); register "cons" (fun args -> match args with - | [x; List l] -> List (x :: l) + | [x; List l] | [x; ListRef { contents = l }] -> List (x :: l) + | [x; Nil] -> List [x] | _ -> raise (Eval_error "cons: value and list")); register "append" (fun args -> let all = List.concat_map (fun a -> as_list a) args in List all); register "reverse" (fun args -> - match args with [List l] -> List (List.rev l) | _ -> raise (Eval_error "reverse: 1 list")); + match args with + | [List l] | [ListRef { contents = l }] -> List (List.rev l) + | _ -> raise (Eval_error "reverse: 1 list")); register "flatten" (fun args -> let rec flat = function - | List items -> List.concat_map flat items + | List items | ListRef { contents = items } -> List.concat_map flat items | x -> [x] in - match args with [List l] -> List (List.concat_map flat l) | _ -> raise (Eval_error "flatten: 1 list")); + match args with + | [List l] | [ListRef { contents = l }] -> List (List.concat_map flat l) + | _ -> raise (Eval_error "flatten: 1 list")); register "concat" (fun args -> List (List.concat_map as_list args)); register "contains?" (fun args -> match args with - | [List l; item] -> Bool (List.mem item l) + | [List l; item] | [ListRef { contents = l }; item] -> Bool (List.mem item l) | [String s; String sub] -> let rec find i = if i + String.length sub > String.length s then false @@ -329,14 +369,25 @@ let () = let s = int_of_float start and e = int_of_float stop in let len = max 0 (e - s) in List (List.init len (fun i -> Number (float_of_int (s + i)))) - | _ -> raise (Eval_error "range: 1-2 args")); + | [Number start; Number stop; Number step] -> + let s = start and e = stop and st = step in + if st = 0.0 then List [] + else + let items = ref [] in + let i = ref s in + if st > 0.0 then + (while !i < e do items := Number !i :: !items; i := !i +. st done) + else + (while !i > e do items := Number !i :: !items; i := !i +. st done); + List (List.rev !items) + | _ -> raise (Eval_error "range: 1-3 args")); register "slice" (fun args -> match args with - | [List l; Number start] -> + | [(List l | ListRef { contents = l }); Number start] -> let i = max 0 (int_of_float start) in let rec drop n = function _ :: xs when n > 0 -> drop (n-1) xs | l -> l in List (drop i l) - | [List l; Number start; Number end_] -> + | [(List l | ListRef { contents = l }); Number start; Number end_] -> let i = max 0 (int_of_float start) and j = int_of_float end_ in let len = List.length l in let j = min j len in @@ -358,19 +409,21 @@ let () = | _ -> raise (Eval_error "slice: 2-3 args")); register "sort" (fun args -> match args with - | [List l] -> List (List.sort compare l) + | [List l] | [ListRef { contents = l }] -> List (List.sort compare l) | _ -> raise (Eval_error "sort: 1 list")); register "zip" (fun args -> match args with - | [List a; List b] -> + | [a; b] -> + let la = as_list a and lb = as_list b in let rec go l1 l2 acc = match l1, l2 with | x :: xs, y :: ys -> go xs ys (List [x; y] :: acc) | _ -> List.rev acc - in List (go a b []) + in List (go la lb []) | _ -> raise (Eval_error "zip: 2 lists")); register "zip-pairs" (fun args -> match args with - | [List l] -> + | [v] -> + let l = as_list v in let rec go = function | a :: b :: rest -> List [a; b] :: go rest | _ -> [] @@ -378,7 +431,7 @@ let () = | _ -> raise (Eval_error "zip-pairs: 1 list")); register "take" (fun args -> match args with - | [List l; Number n] -> + | [(List l | ListRef { contents = l }); Number n] -> let rec take_n i = function | x :: xs when i > 0 -> x :: take_n (i-1) xs | _ -> [] @@ -386,7 +439,7 @@ let () = | _ -> raise (Eval_error "take: list and number")); register "drop" (fun args -> match args with - | [List l; Number n] -> + | [(List l | ListRef { contents = l }); Number n] -> let rec drop_n i = function | _ :: xs when i > 0 -> drop_n (i-1) xs | l -> l @@ -394,7 +447,7 @@ let () = | _ -> raise (Eval_error "drop: list and number")); register "chunk-every" (fun args -> match args with - | [List l; Number n] -> + | [(List l | ListRef { contents = l }); Number n] -> let size = int_of_float n in let rec go = function | [] -> [] @@ -412,7 +465,7 @@ let () = | _ -> raise (Eval_error "chunk-every: list and number")); register "unique" (fun args -> match args with - | [List l] -> + | [(List l | ListRef { contents = l })] -> let seen = Hashtbl.create 16 in let result = List.filter (fun x -> let key = inspect x in @@ -435,7 +488,8 @@ let () = match args with | [Dict d; String k] -> dict_get d k | [Dict d; Keyword k] -> dict_get d k - | [List l; Number n] -> (try List.nth l (int_of_float n) with _ -> Nil) + | [List l; Number n] | [ListRef { contents = l }; Number n] -> + (try List.nth l (int_of_float n) with _ -> Nil) | _ -> raise (Eval_error "get: dict+key or list+index")); register "has-key?" (fun args -> match args with diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index 9c63623..ba26d3e 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -6,12 +6,16 @@ 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 === *) +let _strict_ref = ref (Bool false) +let _prim_param_types_ref = ref Nil + (* === Transpiled from evaluator (frames + eval + CEK) === *) (* make-cek-state *) @@ -202,21 +206,19 @@ 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* *) -and _strict_ = - (Bool false) +(* *strict* — reads from mutable ref each time *) +and _strict_ = !_strict_ref (* set-strict! *) and set_strict_b val' = - let _strict_ = ref Nil in (_strict_ := val'; Nil) + _strict_ref := val'; Nil -(* *prim-param-types* *) -and _prim_param_types_ = - Nil +(* *prim-param-types* — reads from mutable ref *) +and _prim_param_types_ = !_prim_param_types_ref (* set-prim-param-types! *) and set_prim_param_types_b types = - let _prim_param_types_ = ref Nil in (_prim_param_types_ := types; Nil) + _prim_param_types_ref := types; Nil (* value-matches-type? *) and value_matches_type_p val' expected_type = @@ -224,7 +226,7 @@ and value_matches_type_p val' expected_type = (* strict-check-args *) and strict_check_args name args = - (if sx_truthy ((let _and = _strict_ in if not (sx_truthy _and) then _and else _prim_param_types_)) then (let spec = (get (_prim_param_types_) (name)) in (if sx_truthy (spec) then (let positional = (get (spec) ((String "positional"))) in let rest_type = (get (spec) ((String "rest-type"))) in (let () = ignore ((if sx_truthy (positional) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let param = (nth (pair) ((Number 1.0))) in let p_name = (first (param)) in let p_type = (nth (param) ((Number 1.0))) in (if sx_truthy ((prim_call "<" [idx; (len (args))])) then (let val' = (nth (args) (idx)) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (p_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); p_type; (String " for param "); p_name; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [i; p])) (sx_to_list positional)))); Nil) else Nil)) in (if sx_truthy ((let _and = rest_type in if not (sx_truthy _and) then _and else (prim_call ">" [(len (args)); (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let val' = (nth (pair) ((Number 1.0))) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (rest_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); rest_type; (String " for rest arg "); idx; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)))) (sx_to_list (List (List.mapi (fun i v -> let i = Number (float_of_int i) in (List [i; v])) (sx_to_list (prim_call "slice" [args; (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))))); Nil) else Nil))) else Nil)) else Nil) + (if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else !_prim_param_types_ref)) then (let spec = (get (!_prim_param_types_ref) (name)) in (if sx_truthy (spec) then (let positional = (get (spec) ((String "positional"))) in let rest_type = (get (spec) ((String "rest-type"))) in (let () = ignore ((if sx_truthy (positional) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let param = (nth (pair) ((Number 1.0))) in let p_name = (first (param)) in let p_type = (nth (param) ((Number 1.0))) in (if sx_truthy ((prim_call "<" [idx; (len (args))])) then (let val' = (nth (args) (idx)) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (p_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); p_type; (String " for param "); p_name; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [i; p])) (sx_to_list positional)))); Nil) else Nil)) in (if sx_truthy ((let _and = rest_type in if not (sx_truthy _and) then _and else (prim_call ">" [(len (args)); (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let val' = (nth (pair) ((Number 1.0))) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (rest_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); rest_type; (String " for rest arg "); idx; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)))) (sx_to_list (List (List.mapi (fun i v -> let i = Number (float_of_int i) in (List [i; v])) (sx_to_list (prim_call "slice" [args; (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))))); Nil) else Nil))) else Nil)) else Nil) (* call-lambda *) and call_lambda f args caller_env = @@ -236,7 +238,7 @@ and call_component comp raw_args env = (* parse-keyword-args *) and parse_keyword_args raw_args env = - (let kwargs = (Dict (Hashtbl.create 0)) in let children = (List []) in let i = (Number 0.0) in (let () = ignore ((List.fold_left (fun state arg -> (let idx = (get (state) ((String "i"))) in let skip = (get (state) ((String "skip"))) in (if sx_truthy (skip) then (prim_call "assoc" [state; (String "skip"); (Bool false); (String "i"); (prim_call "inc" [idx])]) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (arg)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "<" [(prim_call "inc" [idx]); (len (raw_args))]))) then (let () = ignore ((sx_dict_set_b kwargs (keyword_name (arg)) (trampoline ((eval_expr ((nth (raw_args) ((prim_call "inc" [idx])))) (env)))))) in (prim_call "assoc" [state; (String "skip"); (Bool true); (String "i"); (prim_call "inc" [idx])])) else (let () = ignore ((sx_append_b children (trampoline ((eval_expr (arg) (env)))))) in (prim_call "assoc" [state; (String "i"); (prim_call "inc" [idx])])))))) (let _d = Hashtbl.create 2 in Hashtbl.replace _d (value_to_str (String "i")) (Number 0.0); Hashtbl.replace _d (value_to_str (String "skip")) (Bool false); Dict _d) (sx_to_list raw_args))) in (List [kwargs; children]))) + (let kwargs = (Dict (Hashtbl.create 0)) in let children = ref ((List [])) in let i = (Number 0.0) in (let () = ignore ((List.fold_left (fun state arg -> (let idx = (get (state) ((String "i"))) in let skip = (get (state) ((String "skip"))) in (if sx_truthy (skip) then (prim_call "assoc" [state; (String "skip"); (Bool false); (String "i"); (prim_call "inc" [idx])]) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (arg)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "<" [(prim_call "inc" [idx]); (len (raw_args))]))) then (let () = ignore ((sx_dict_set_b kwargs (keyword_name (arg)) (trampoline ((eval_expr ((nth (raw_args) ((prim_call "inc" [idx])))) (env)))))) in (prim_call "assoc" [state; (String "skip"); (Bool true); (String "i"); (prim_call "inc" [idx])])) else (let () = ignore ((children := sx_append_b !children (trampoline ((eval_expr (arg) (env)))); Nil)) in (prim_call "assoc" [state; (String "i"); (prim_call "inc" [idx])])))))) (let _d = Hashtbl.create 2 in Hashtbl.replace _d (value_to_str (String "i")) (Number 0.0); Hashtbl.replace _d (value_to_str (String "skip")) (Bool false); Dict _d) (sx_to_list raw_args))) in (List [kwargs; !children]))) (* cond-scheme? *) and cond_scheme_p clauses = @@ -244,7 +246,7 @@ and cond_scheme_p clauses = (* 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 = (List []) in let inits = (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 ((sx_append_b params (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))))) in (sx_append_b inits (nth (binding) ((Number 1.0))))))) (sx_to_list bindings); Nil) else (List.fold_left (fun _acc pair_idx -> (let () = ignore ((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)])))))) in (sx_append_b inits (nth (bindings) ((prim_call "inc" [(prim_call "*" [pair_idx; (Number 2.0)])])))))) 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)))))))) + (let loop_name = (symbol_name ((first (args)))) in let bindings = (nth (args) ((Number 1.0))) in let body = (prim_call "slice" [args; (Number 2.0)]) in let params = ref ((List [])) in let inits = ref ((List [])) in (let () = ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (List.iter (fun binding -> ignore ((let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))); Nil)) in (inits := sx_append_b !inits (nth (binding) ((Number 1.0))); Nil)))) (sx_to_list bindings); Nil) else (List.fold_left (fun _acc pair_idx -> (let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))); (String "symbol")])) then (symbol_name ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))) else (nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)])))); Nil)) in (inits := sx_append_b !inits (nth (bindings) ((prim_call "inc" [(prim_call "*" [pair_idx; (Number 2.0)])]))); Nil))) Nil (sx_to_list (prim_call "range" [(Number 0.0); (prim_call "/" [(len (bindings)); (Number 2.0)])]))))) in (let loop_body = (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (first (body)) else (cons ((make_symbol ((String "begin")))) (body))) in let loop_fn = (make_lambda (!params) (loop_body) (env)) in (let () = ignore ((set_lambda_name loop_fn (sx_to_string loop_name))) in (let () = ignore ((env_bind (lambda_closure (loop_fn)) (sx_to_string loop_name) loop_fn)) in (let init_vals = (List (List.map (fun e -> (trampoline ((eval_expr (e) (env))))) (sx_to_list !inits))) in (call_lambda (loop_fn) (init_vals) (env)))))))) (* sf-lambda *) and sf_lambda args env = @@ -260,7 +262,7 @@ and defcomp_kwarg args key default = (* parse-comp-params *) and parse_comp_params params_expr = - (let params = (List []) in let param_types = (Dict (Hashtbl.create 0)) in let has_children = ref ((Bool false)) in let in_key = ref ((Bool false)) in (let () = ignore ((List.iter (fun p -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (p)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (p)); (Number 3.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (p)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (p) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (p) ((Number 1.0))))); (String "as")])))))) then (let name = (symbol_name ((first (p)))) in let ptype = (nth (p) ((Number 2.0))) in (let type_val = (if sx_truthy ((prim_call "=" [(type_of (ptype)); (String "symbol")])) then (symbol_name (ptype)) else ptype) in (if sx_truthy ((Bool (not (sx_truthy (!has_children))))) then (let () = ignore ((sx_append_b params name)) in (sx_dict_set_b param_types name type_val)) else Nil))) else (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (let name = (symbol_name (p)) in (if sx_truthy ((prim_call "=" [name; (String "&key")])) then (in_key := (Bool true); Nil) else (if sx_truthy ((prim_call "=" [name; (String "&rest")])) then (has_children := (Bool true); Nil) else (if sx_truthy ((prim_call "=" [name; (String "&children")])) then (has_children := (Bool true); Nil) else (if sx_truthy (!has_children) then Nil else (if sx_truthy (!in_key) then (sx_append_b params name) else (sx_append_b params name))))))) else Nil)))) (sx_to_list params_expr); Nil)) in (List [params; !has_children; param_types]))) + (let params = ref ((List [])) in let param_types = (Dict (Hashtbl.create 0)) in let has_children = ref ((Bool false)) in let in_key = ref ((Bool false)) in (let () = ignore ((List.iter (fun p -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (p)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (p)); (Number 3.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (p)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (p) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (p) ((Number 1.0))))); (String "as")])))))) then (let name = (symbol_name ((first (p)))) in let ptype = (nth (p) ((Number 2.0))) in (let type_val = (if sx_truthy ((prim_call "=" [(type_of (ptype)); (String "symbol")])) then (symbol_name (ptype)) else ptype) in (if sx_truthy ((Bool (not (sx_truthy (!has_children))))) then (let () = ignore ((params := sx_append_b !params name; Nil)) in (sx_dict_set_b param_types name type_val)) else Nil))) else (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (let name = (symbol_name (p)) in (if sx_truthy ((prim_call "=" [name; (String "&key")])) then (in_key := (Bool true); Nil) else (if sx_truthy ((prim_call "=" [name; (String "&rest")])) then (has_children := (Bool true); Nil) else (if sx_truthy ((prim_call "=" [name; (String "&children")])) then (has_children := (Bool true); Nil) else (if sx_truthy (!has_children) then Nil else (if sx_truthy (!in_key) then (params := sx_append_b !params name; Nil) else (params := sx_append_b !params name; Nil))))))) else Nil)))) (sx_to_list params_expr); Nil)) in (List [!params; !has_children; param_types]))) (* sf-defisland *) and sf_defisland args env = @@ -272,7 +274,7 @@ and sf_defmacro args env = (* parse-macro-params *) and parse_macro_params params_expr = - (let params = (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 ((sx_append_b params (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else p))) 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]))) + (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 = @@ -292,7 +294,7 @@ and sf_deftype args env = (* 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 = (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 (sx_append_b registry effect_name) else Nil)) in (let () = ignore ((env_bind env (sx_to_string (String "*effect-registry*")) registry)) in Nil))) + (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 = @@ -300,7 +302,7 @@ and qq_expand template env = (* sf-letrec *) and sf_letrec args env = - (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in let names = (List []) in let val_exprs = (List []) in (let () = ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (List.iter (fun binding -> ignore ((let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))) in (let () = ignore ((sx_append_b names vname)) in (let () = ignore ((sx_append_b val_exprs (nth (binding) ((Number 1.0))))) in (env_bind local (sx_to_string vname) Nil)))))) (sx_to_list bindings); Nil) else (List.fold_left (fun _acc pair_idx -> (let vname = (if sx_truthy ((prim_call "=" [(type_of ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))); (String "symbol")])) then (symbol_name ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))) else (nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)])))) in let val_expr = (nth (bindings) ((prim_call "inc" [(prim_call "*" [pair_idx; (Number 2.0)])]))) in (let () = ignore ((sx_append_b names vname)) in (let () = ignore ((sx_append_b val_exprs val_expr)) in (env_bind local (sx_to_string vname) Nil))))) Nil (sx_to_list (prim_call "range" [(Number 0.0); (prim_call "/" [(len (bindings)); (Number 2.0)])]))))) in (let () = ignore ((let values = (List (List.map (fun e -> (trampoline ((eval_expr (e) (local))))) (sx_to_list val_exprs))) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [names; values])); Nil)) in (List.iter (fun val' -> ignore ((if sx_truthy ((is_lambda (val'))) then (List.iter (fun n -> ignore ((env_bind (lambda_closure (val')) (sx_to_string n) (env_get (local) (n))))) (sx_to_list names); Nil) else Nil))) (sx_to_list values); Nil)))) in (let () = ignore ((List.iter (fun e -> ignore ((trampoline ((eval_expr (e) (local)))))) (sx_to_list (prim_call "slice" [body; (Number 0.0); (prim_call "dec" [(len (body))])])); Nil)) in (make_thunk ((last (body))) (local)))))) + (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in let names = ref ((List [])) in let val_exprs = ref ((List [])) in (let () = ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (List.iter (fun binding -> ignore ((let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))) in (let () = ignore ((names := sx_append_b !names vname; Nil)) in (let () = ignore ((val_exprs := sx_append_b !val_exprs (nth (binding) ((Number 1.0))); Nil)) in (env_bind local (sx_to_string vname) Nil)))))) (sx_to_list bindings); Nil) else (List.fold_left (fun _acc pair_idx -> (let vname = (if sx_truthy ((prim_call "=" [(type_of ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))); (String "symbol")])) then (symbol_name ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))) else (nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)])))) in let val_expr = (nth (bindings) ((prim_call "inc" [(prim_call "*" [pair_idx; (Number 2.0)])]))) in (let () = ignore ((names := sx_append_b !names vname; Nil)) in (let () = ignore ((val_exprs := sx_append_b !val_exprs val_expr; Nil)) in (env_bind local (sx_to_string vname) Nil))))) Nil (sx_to_list (prim_call "range" [(Number 0.0); (prim_call "/" [(len (bindings)); (Number 2.0)])]))))) in (let () = ignore ((let values = (List (List.map (fun e -> (trampoline ((eval_expr (e) (local))))) (sx_to_list !val_exprs))) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [!names; values])); Nil)) in (List.iter (fun val' -> ignore ((if sx_truthy ((is_lambda (val'))) then (List.iter (fun n -> ignore ((env_bind (lambda_closure (val')) (sx_to_string n) (env_get (local) (n))))) (sx_to_list !names); Nil) else Nil))) (sx_to_list values); Nil)))) in (let () = ignore ((List.iter (fun e -> ignore ((trampoline ((eval_expr (e) (local)))))) (sx_to_list (prim_call "slice" [body; (Number 0.0); (prim_call "dec" [(len (body))])])); Nil)) in (make_thunk ((last (body))) (local)))))) (* sf-dynamic-wind *) and sf_dynamic_wind args env = @@ -328,7 +330,7 @@ and cek_step state = (* step-eval *) and step_eval state = - (let expr = (cek_control (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (let _match_val = (type_of (expr)) in (if _match_val = (String "number") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "string") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "boolean") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "nil") then (make_cek_value (Nil) (env) (kont)) else (if _match_val = (String "symbol") then (let name = (symbol_name (expr)) in (let val' = (if sx_truthy ((env_has (env) (name))) then (env_get (env) (name)) else (if sx_truthy ((is_primitive (name))) then (get_primitive (name)) else (if sx_truthy ((prim_call "=" [name; (String "true")])) then (Bool true) else (if sx_truthy ((prim_call "=" [name; (String "false")])) then (Bool false) else (if sx_truthy ((prim_call "=" [name; (String "nil")])) then Nil else (raise (Eval_error (value_to_str (String (sx_str [(String "Undefined symbol: "); name])))))))))) in (make_cek_value (val') (env) (kont)))) else (if _match_val = (String "keyword") then (make_cek_value ((keyword_name (expr))) (env) (kont)) else (if _match_val = (String "dict") then (let ks = (prim_call "keys" [expr]) in (if sx_truthy ((empty_p (ks))) then (make_cek_value ((Dict (Hashtbl.create 0))) (env) (kont)) else (let first_key = (first (ks)) in let remaining_entries = (List []) in (let () = ignore ((List.iter (fun k -> ignore ((sx_append_b remaining_entries (List [k; (get (expr) (k))])))) (sx_to_list (rest (ks))); Nil)) in (make_cek_state ((get (expr) (first_key))) (env) ((kont_push ((make_dict_frame (remaining_entries) ((List [(List [first_key])])) (env))) (kont)))))))) else (if _match_val = (String "list") then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (step_eval_list (expr) (env) (kont))) else (make_cek_value (expr) (env) (kont)))))))))))) + (let expr = (cek_control (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (let _match_val = (type_of (expr)) in (if _match_val = (String "number") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "string") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "boolean") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "nil") then (make_cek_value (Nil) (env) (kont)) else (if _match_val = (String "symbol") then (let name = (symbol_name (expr)) in (let val' = (if sx_truthy ((env_has (env) (name))) then (env_get (env) (name)) else (if sx_truthy ((is_primitive (name))) then (get_primitive (name)) else (if sx_truthy ((prim_call "=" [name; (String "true")])) then (Bool true) else (if sx_truthy ((prim_call "=" [name; (String "false")])) then (Bool false) else (if sx_truthy ((prim_call "=" [name; (String "nil")])) then Nil else (raise (Eval_error (value_to_str (String (sx_str [(String "Undefined symbol: "); name])))))))))) in (make_cek_value (val') (env) (kont)))) else (if _match_val = (String "keyword") then (make_cek_value ((keyword_name (expr))) (env) (kont)) else (if _match_val = (String "dict") then (let ks = (prim_call "keys" [expr]) in (if sx_truthy ((empty_p (ks))) then (make_cek_value ((Dict (Hashtbl.create 0))) (env) (kont)) else (let first_key = (first (ks)) in let remaining_entries = ref ((List [])) in (let () = ignore ((List.iter (fun k -> ignore ((remaining_entries := sx_append_b !remaining_entries (List [k; (get (expr) (k))]); Nil))) (sx_to_list (rest (ks))); Nil)) in (make_cek_state ((get (expr) (first_key))) (env) ((kont_push ((make_dict_frame (!remaining_entries) ((List [(List [first_key])])) (env))) (kont)))))))) else (if _match_val = (String "list") then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (step_eval_list (expr) (env) (kont))) else (make_cek_value (expr) (env) (kont)))))))))))) (* step-eval-list *) and step_eval_list expr env kont = @@ -348,7 +350,7 @@ and step_sf_begin args env kont = (* step-sf-let *) and step_sf_let args env kont = - (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (make_cek_value ((sf_named_let (args) (env))) (env) (kont)) else (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in (if sx_truthy ((empty_p (bindings))) then (step_sf_begin (body) (local) (kont)) else (let first_binding = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (first (bindings)) else (List [(first (bindings)); (nth (bindings) ((Number 1.0)))])) in let rest_bindings = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (rest (bindings)) else (let pairs = (List []) in (let () = ignore ((List.fold_left (fun _acc i -> (sx_append_b pairs (List [(nth (bindings) ((prim_call "*" [i; (Number 2.0)]))); (nth (bindings) ((prim_call "inc" [(prim_call "*" [i; (Number 2.0)])])))]))) Nil (sx_to_list (prim_call "range" [(Number 1.0); (prim_call "/" [(len (bindings)); (Number 2.0)])])))) in pairs))) in (let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (first_binding)))); (String "symbol")])) then (symbol_name ((first (first_binding)))) else (first (first_binding))) in (make_cek_state ((nth (first_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) (rest_bindings) (body) (local))) (kont))))))))) + let pairs = ref Nil in (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (make_cek_value ((sf_named_let (args) (env))) (env) (kont)) else (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in (if sx_truthy ((empty_p (bindings))) then (step_sf_begin (body) (local) (kont)) else (let first_binding = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (first (bindings)) else (List [(first (bindings)); (nth (bindings) ((Number 1.0)))])) in let rest_bindings = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (rest (bindings)) else (let pairs = ref ((List [])) in (let () = ignore ((List.fold_left (fun _acc i -> (pairs := sx_append_b !pairs (List [(nth (bindings) ((prim_call "*" [i; (Number 2.0)]))); (nth (bindings) ((prim_call "inc" [(prim_call "*" [i; (Number 2.0)])])))]); Nil)) Nil (sx_to_list (prim_call "range" [(Number 1.0); (prim_call "/" [(len (bindings)); (Number 2.0)])])))) in !pairs))) in (let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (first_binding)))); (String "symbol")])) then (symbol_name ((first (first_binding)))) else (first (first_binding))) in (make_cek_state ((nth (first_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) (rest_bindings) (body) (local))) (kont))))))))) (* step-sf-define *) and step_sf_define args env kont = @@ -420,7 +422,7 @@ and cek_call f args = (* reactive-shift-deref *) and reactive_shift_deref sig' env kont = - (let scan_result = (kont_capture_to_reactive_reset (kont)) in let captured_frames = (first (scan_result)) in let reset_frame = (nth (scan_result) ((Number 1.0))) in let remaining_kont = (nth (scan_result) ((Number 2.0))) in let update_fn = (get (reset_frame) ((String "update-fn"))) in (let sub_disposers = ref ((List [])) in (let subscriber = (fun () -> let sub_disposers = ref Nil in (let () = ignore ((List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil)) in (let () = ignore ((sub_disposers := (List []); Nil)) in (let new_reset = (make_reactive_reset_frame (env) (update_fn) ((Bool false))) in let new_kont = (prim_call "concat" [captured_frames; (List [new_reset]); remaining_kont]) in (with_island_scope ((fun d -> (sx_append_b !sub_disposers d))) ((fun () -> (cek_run ((make_cek_value ((signal_value (sig'))) (env) (new_kont))))))))))) in (let () = ignore ((signal_add_sub_b (sig') (subscriber))) in (let () = ignore ((register_in_scope ((fun () -> (let () = ignore ((signal_remove_sub_b (sig') (subscriber))) in (List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil)))))) in (let initial_kont = (prim_call "concat" [captured_frames; (List [reset_frame]); remaining_kont]) in (make_cek_value ((signal_value (sig'))) (env) (initial_kont)))))))) + (let scan_result = (kont_capture_to_reactive_reset (kont)) in let captured_frames = (first (scan_result)) in let reset_frame = (nth (scan_result) ((Number 1.0))) in let remaining_kont = (nth (scan_result) ((Number 2.0))) in let update_fn = (get (reset_frame) ((String "update-fn"))) in (let sub_disposers = ref ((List [])) in (let subscriber = (fun () -> let sub_disposers = ref Nil in (let () = ignore ((List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil)) in (let () = ignore ((sub_disposers := (List []); Nil)) in (let new_reset = (make_reactive_reset_frame (env) (update_fn) ((Bool false))) in let new_kont = (prim_call "concat" [captured_frames; (List [new_reset]); remaining_kont]) in (with_island_scope ((fun d -> let sub_disposers = ref Nil in (sub_disposers := sx_append_b !sub_disposers d; Nil))) ((fun () -> (cek_run ((make_cek_value ((signal_value (sig'))) (env) (new_kont))))))))))) in (let () = ignore ((signal_add_sub_b (sig') (subscriber))) in (let () = ignore ((register_in_scope ((fun () -> (let () = ignore ((signal_remove_sub_b (sig') (subscriber))) in (List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil)))))) in (let initial_kont = (prim_call "concat" [captured_frames; (List [reset_frame]); remaining_kont]) in (make_cek_value ((signal_value (sig'))) (env) (initial_kont)))))))) (* step-eval-call *) and step_eval_call head args env kont = @@ -472,7 +474,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_ 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_ 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 = (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 ((sx_append_b dep_list val')) 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 ((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])))))))))))))))))))))))))))))))))) (* continue-with-call *) and continue_with_call f args env raw_args kont = @@ -555,6 +557,12 @@ and eval_expr expr env = (cek_run ((make_cek_state (expr) (env) ((List []))))) +(* Wire up trampoline to resolve thunks via the CEK machine *) +let () = trampoline_fn := (fun v -> + match v with + | Thunk (expr, env) -> eval_expr expr (Env env) + | _ -> v) + (* Override recursive cek_run with iterative loop *) let cek_run_iterative state = let s = ref state in diff --git a/hosts/ocaml/lib/sx_render.ml b/hosts/ocaml/lib/sx_render.ml new file mode 100644 index 0000000..629cde6 --- /dev/null +++ b/hosts/ocaml/lib/sx_render.ml @@ -0,0 +1,435 @@ +(** HTML renderer for SX values. + + Extracted from run_tests.ml — renders an SX expression tree to an + HTML string, expanding components and macros along the way. + + Depends on [Sx_ref.eval_expr] for evaluating sub-expressions + during rendering (keyword arg values, conditionals, etc.). *) + +open Sx_types + +(* ====================================================================== *) +(* Tag / attribute registries *) +(* ====================================================================== *) + +let html_tags = [ + "html"; "head"; "body"; "title"; "meta"; "link"; "script"; "style"; "noscript"; + "header"; "nav"; "main"; "section"; "article"; "aside"; "footer"; + "h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "hgroup"; + "div"; "p"; "blockquote"; "pre"; "figure"; "figcaption"; "address"; "hr"; + "ul"; "ol"; "li"; "dl"; "dt"; "dd"; "menu"; + "a"; "span"; "em"; "strong"; "small"; "b"; "i"; "u"; "s"; "sub"; "sup"; + "mark"; "del"; "ins"; "q"; "cite"; "dfn"; "abbr"; "code"; "var"; "samp"; + "kbd"; "data"; "time"; "ruby"; "rt"; "rp"; "bdi"; "bdo"; "wbr"; "br"; + "table"; "thead"; "tbody"; "tfoot"; "tr"; "th"; "td"; "caption"; "colgroup"; "col"; + "form"; "input"; "textarea"; "select"; "option"; "optgroup"; "button"; "label"; + "fieldset"; "legend"; "datalist"; "output"; "progress"; "meter"; + "details"; "summary"; "dialog"; + "img"; "video"; "audio"; "source"; "picture"; "canvas"; "iframe"; "embed"; "object"; "param"; + "svg"; "path"; "circle"; "rect"; "line"; "polyline"; "polygon"; "ellipse"; + "g"; "defs"; "use"; "text"; "tspan"; "clipPath"; "mask"; "pattern"; + "linearGradient"; "radialGradient"; "stop"; "filter"; "feBlend"; "feFlood"; + "feGaussianBlur"; "feOffset"; "feMerge"; "feMergeNode"; "feComposite"; + "template"; "slot"; +] + +let void_elements = [ + "area"; "base"; "br"; "col"; "embed"; "hr"; "img"; "input"; + "link"; "meta"; "param"; "source"; "track"; "wbr" +] + +let boolean_attrs = [ + "async"; "autofocus"; "autoplay"; "checked"; "controls"; "default"; + "defer"; "disabled"; "formnovalidate"; "hidden"; "inert"; "ismap"; + "loop"; "multiple"; "muted"; "nomodule"; "novalidate"; "open"; + "playsinline"; "readonly"; "required"; "reversed"; "selected" +] + +let is_html_tag name = List.mem name html_tags +let is_void name = List.mem name void_elements +let is_boolean_attr name = List.mem name boolean_attrs + + +(* ====================================================================== *) +(* HTML escaping *) +(* ====================================================================== *) + +let escape_html s = + let buf = Buffer.create (String.length s) in + String.iter (function + | '&' -> Buffer.add_string buf "&" + | '<' -> Buffer.add_string buf "<" + | '>' -> Buffer.add_string buf ">" + | '"' -> Buffer.add_string buf """ + | c -> Buffer.add_char buf c) s; + Buffer.contents buf + + +(* ====================================================================== *) +(* Attribute rendering *) +(* ====================================================================== *) + +let render_attrs attrs = + let buf = Buffer.create 64 in + Hashtbl.iter (fun k v -> + if is_boolean_attr k then begin + if sx_truthy v then begin + Buffer.add_char buf ' '; + Buffer.add_string buf k + end + end else if not (is_nil v) then begin + Buffer.add_char buf ' '; + Buffer.add_string buf k; + Buffer.add_string buf "=\""; + Buffer.add_string buf (escape_html (value_to_string v)); + Buffer.add_char buf '"' + end) attrs; + Buffer.contents buf + + +(* ====================================================================== *) +(* HTML renderer *) +(* ====================================================================== *) + +(* Forward ref — resolved at setup time *) +let render_to_html_ref : (value -> env -> string) ref = + ref (fun _expr _env -> "") + +let render_to_html expr env = !render_to_html_ref expr env + +let render_children children env = + String.concat "" (List.map (fun c -> render_to_html c env) children) + +(** Parse keyword attrs and positional children from an element call's args. + Attrs are evaluated; children are returned UNEVALUATED for render dispatch. *) +let parse_element_args args env = + let attrs = Hashtbl.create 8 in + let children = ref [] in + let skip = ref false in + let len = List.length args in + List.iteri (fun idx arg -> + if !skip then skip := false + else match arg with + | Keyword k when idx + 1 < len -> + let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in + Hashtbl.replace attrs k v; + skip := true + | Spread pairs -> + List.iter (fun (k, v) -> Hashtbl.replace attrs k v) pairs + | _ -> + children := arg :: !children + ) args; + (attrs, List.rev !children) + +let render_html_element tag args env = + let (attrs, children) = parse_element_args args env in + let attr_str = render_attrs attrs in + if is_void tag then + "<" ^ tag ^ attr_str ^ " />" + else + let content = String.concat "" + (List.map (fun c -> render_to_html c env) children) in + "<" ^ tag ^ attr_str ^ ">" ^ content ^ "" + +let render_component comp args env = + match comp with + | Component c -> + let kwargs = Hashtbl.create 8 in + let children_exprs = ref [] in + let skip = ref false in + let len = List.length args in + List.iteri (fun idx arg -> + if !skip then skip := false + else match arg with + | Keyword k when idx + 1 < len -> + let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in + Hashtbl.replace kwargs k v; + skip := true + | _ -> + children_exprs := arg :: !children_exprs + ) args; + let children = List.rev !children_exprs in + let local = env_merge c.c_closure env in + List.iter (fun p -> + let v = match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil in + ignore (env_bind local p v) + ) c.c_params; + if c.c_has_children then begin + let rendered_children = String.concat "" + (List.map (fun c -> render_to_html c env) children) in + ignore (env_bind local "children" (RawHTML rendered_children)) + end; + render_to_html c.c_body local + | _ -> "" + +let expand_macro (m : macro) args _env = + let local = env_extend m.m_closure in + let params = m.m_params in + let rec bind_params ps as' = + match ps, as' with + | [], rest -> + (match m.m_rest_param with + | Some rp -> ignore (env_bind local rp (List rest)) + | None -> ()) + | p :: ps_rest, a :: as_rest -> + ignore (env_bind local p a); + bind_params ps_rest as_rest + | _ :: _, [] -> + List.iter (fun p -> ignore (env_bind local p Nil)) (List.rev ps) + in + bind_params params args; + Sx_ref.eval_expr m.m_body (Env local) + +let rec do_render_to_html (expr : value) (env : env) : string = + match expr with + | Nil -> "" + | Bool true -> "true" + | Bool false -> "false" + | Number n -> + if Float.is_integer n then string_of_int (int_of_float n) + else Printf.sprintf "%g" n + | String s -> escape_html s + | Keyword k -> escape_html k + | RawHTML s -> s + | Symbol s -> + let v = Sx_ref.eval_expr (Symbol s) (Env env) in + do_render_to_html v env + | List [] | ListRef { contents = [] } -> "" + | List (head :: args) | ListRef { contents = head :: args } -> + render_list_to_html head args env + | _ -> + let v = Sx_ref.eval_expr expr (Env env) in + do_render_to_html v env + +and render_list_to_html head args env = + match head with + | Symbol "<>" -> + render_children args env + | Symbol tag when is_html_tag tag -> + render_html_element tag args env + | Symbol "if" -> + let cond_val = Sx_ref.eval_expr (List.hd args) (Env env) in + if sx_truthy cond_val then + (if List.length args > 1 then do_render_to_html (List.nth args 1) env else "") + else + (if List.length args > 2 then do_render_to_html (List.nth args 2) env else "") + | Symbol "when" -> + let cond_val = Sx_ref.eval_expr (List.hd args) (Env env) in + if sx_truthy cond_val then + String.concat "" (List.map (fun e -> do_render_to_html e env) (List.tl args)) + else "" + | Symbol "cond" -> + render_cond args env + | Symbol "case" -> + let v = Sx_ref.eval_expr (List (head :: args)) (Env env) in + do_render_to_html v env + | Symbol ("let" | "let*") -> + render_let args env + | Symbol ("begin" | "do") -> + let rec go = function + | [] -> "" + | [last] -> do_render_to_html last env + | e :: rest -> + ignore (Sx_ref.eval_expr e (Env env)); + go rest + in go args + | Symbol ("define" | "defcomp" | "defmacro" | "defisland") -> + ignore (Sx_ref.eval_expr (List (head :: args)) (Env env)); + "" + | Symbol "map" -> + render_map args env false + | Symbol "map-indexed" -> + render_map args env true + | Symbol "filter" -> + let v = Sx_ref.eval_expr (List (head :: args)) (Env env) in + do_render_to_html v env + | Symbol "for-each" -> + render_for_each args env + | Symbol name -> + (try + let v = env_get env name in + (match v with + | Component _ -> render_component v args env + | Macro m -> + let expanded = expand_macro m args env in + do_render_to_html expanded env + | _ -> + let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in + do_render_to_html result env) + with Eval_error _ -> + let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in + do_render_to_html result env) + | _ -> + let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in + do_render_to_html result env + +and render_cond args env = + let as_list = function List l | ListRef { contents = l } -> Some l | _ -> None in + let is_scheme = List.for_all (fun a -> match as_list a with + | Some items when List.length items = 2 -> true + | _ -> false) args + in + if is_scheme then begin + let rec go = function + | [] -> "" + | clause :: rest -> + (match as_list clause with + | Some [test; body] -> + let is_else = match test with + | Keyword "else" -> true + | Symbol "else" | Symbol ":else" -> true + | _ -> false + in + if is_else then do_render_to_html body env + else + let v = Sx_ref.eval_expr test (Env env) in + if sx_truthy v then do_render_to_html body env + else go rest + | _ -> "") + in go args + end else begin + let rec go = function + | [] -> "" + | [_] -> "" + | test :: body :: rest -> + let is_else = match test with + | Keyword "else" -> true + | Symbol "else" | Symbol ":else" -> true + | _ -> false + in + if is_else then do_render_to_html body env + else + let v = Sx_ref.eval_expr test (Env env) in + if sx_truthy v then do_render_to_html body env + else go rest + in go args + end + +and render_let args env = + let as_list = function List l | ListRef { contents = l } -> Some l | _ -> None in + let bindings_expr = List.hd args in + let body = List.tl args in + let local = env_extend env in + let bindings = match as_list bindings_expr with Some l -> l | None -> [] in + let is_scheme = match bindings with + | (List _ :: _) | (ListRef _ :: _) -> true + | _ -> false + in + if is_scheme then + List.iter (fun b -> + match as_list b with + | Some [Symbol name; expr] | Some [String name; expr] -> + let v = Sx_ref.eval_expr expr (Env local) in + ignore (env_bind local name v) + | _ -> () + ) bindings + else begin + let rec go = function + | [] -> () + | (Symbol name) :: expr :: rest | (String name) :: expr :: rest -> + let v = Sx_ref.eval_expr expr (Env local) in + ignore (env_bind local name v); + go rest + | _ -> () + in go bindings + end; + let rec render_body = function + | [] -> "" + | [last] -> do_render_to_html last local + | e :: rest -> + ignore (Sx_ref.eval_expr e (Env local)); + render_body rest + in render_body body + +and render_map args env indexed = + let (fn_val, coll_val) = match args with + | [a; b] -> + let va = Sx_ref.eval_expr a (Env env) in + let vb = Sx_ref.eval_expr b (Env env) in + (match va, vb with + | (Lambda _ | NativeFn _), _ -> (va, vb) + | _, (Lambda _ | NativeFn _) -> (vb, va) + | _ -> (va, vb)) + | _ -> (Nil, Nil) + in + let items = match coll_val with List l | ListRef { contents = l } -> l | _ -> [] in + String.concat "" (List.mapi (fun i item -> + let call_args = if indexed then [Number (float_of_int i); item] else [item] in + match fn_val with + | Lambda l -> + let local = env_extend l.l_closure in + List.iter2 (fun p a -> ignore (env_bind local p a)) + l.l_params call_args; + do_render_to_html l.l_body local + | _ -> + let result = Sx_runtime.sx_call fn_val call_args in + do_render_to_html result env + ) items) + +and render_for_each args env = + let (fn_val, coll_val) = match args with + | [a; b] -> + let va = Sx_ref.eval_expr a (Env env) in + let vb = Sx_ref.eval_expr b (Env env) in + (match va, vb with + | (Lambda _ | NativeFn _), _ -> (va, vb) + | _, (Lambda _ | NativeFn _) -> (vb, va) + | _ -> (va, vb)) + | _ -> (Nil, Nil) + in + let items = match coll_val with List l | ListRef { contents = l } -> l | _ -> [] in + String.concat "" (List.map (fun item -> + match fn_val with + | Lambda l -> + let local = env_extend l.l_closure in + List.iter2 (fun p a -> ignore (env_bind local p a)) + l.l_params [item]; + do_render_to_html l.l_body local + | _ -> + let result = Sx_runtime.sx_call fn_val [item] in + do_render_to_html result env + ) items) + + +(* ====================================================================== *) +(* Setup — bind render primitives in an env and wire up the ref *) +(* ====================================================================== *) + +let setup_render_env env = + render_to_html_ref := do_render_to_html; + + let bind name fn = + ignore (env_bind env name (NativeFn (name, fn))) + in + + bind "render-html" (fun args -> + match args with + | [String src] -> + let exprs = Sx_parser.parse_all src in + let expr = match exprs with + | [e] -> e + | [] -> Nil + | _ -> List (Symbol "do" :: exprs) + in + String (render_to_html expr env) + | [expr] -> + String (render_to_html expr env) + | [expr; Env e] -> + String (render_to_html expr e) + | _ -> String ""); + + bind "render-to-html" (fun args -> + match args with + | [String src] -> + let exprs = Sx_parser.parse_all src in + let expr = match exprs with + | [e] -> e + | [] -> Nil + | _ -> List (Symbol "do" :: exprs) + in + String (render_to_html expr env) + | [expr] -> + String (render_to_html expr env) + | [expr; Env e] -> + String (render_to_html expr e) + | _ -> String "") diff --git a/hosts/ocaml/lib/sx_runtime.ml b/hosts/ocaml/lib/sx_runtime.ml index 2b513a4..eedb293 100644 --- a/hosts/ocaml/lib/sx_runtime.ml +++ b/hosts/ocaml/lib/sx_runtime.ml @@ -35,6 +35,7 @@ let sx_str args = (** Convert a value to a list. *) let sx_to_list = function | List l -> l + | ListRef r -> !r | Nil -> [] | v -> raise (Eval_error ("Expected list, got " ^ type_of v)) @@ -60,6 +61,7 @@ let sx_apply f args_list = let sx_append_b lst item = match lst with | List items -> List (items @ [item]) + | ListRef r -> r := !r @ [item]; lst (* mutate in place, return same ref *) | _ -> raise (Eval_error ("append!: expected list, got " ^ type_of lst)) (** Mutable dict-set — set key in dict, return value. *) @@ -74,7 +76,8 @@ let get_val container key = match container, key with | Dict d, String k -> dict_get d k | Dict d, Keyword k -> dict_get d k - | List l, Number n -> (try List.nth l (int_of_float n) with _ -> Nil) + | (List l | ListRef { contents = l }), Number n -> + (try List.nth l (int_of_float n) with _ -> Nil) | _ -> raise (Eval_error ("get: unsupported " ^ type_of container ^ " / " ^ type_of key)) (** Register get as a primitive override — transpiled code calls (get d k). *) @@ -82,7 +85,12 @@ let () = Sx_primitives.register "get" (fun args -> match args with | [c; k] -> get_val c k - | _ -> raise (Eval_error "get: 2 args")) + | [c; k; default] -> + (try + let v = get_val c k in + if v = Nil then default else v + with _ -> default) + | _ -> raise (Eval_error "get: 2-3 args")) (* ====================================================================== *) @@ -195,8 +203,9 @@ let sx_emit a b = prim_call "emit!" [a; b] let sx_emitted a = prim_call "emitted" [a] let sx_context a b = prim_call "context" [a; b] -(* Trampoline — evaluate thunks iteratively *) -let trampoline v = v (* CEK machine doesn't use tree-walk thunks *) +(* Trampoline — forward-declared in sx_ref.ml, delegates to CEK eval_expr *) +(* This is a stub; the real trampoline is wired up in sx_ref.ml after eval_expr is defined *) +let trampoline v = v (* Value-returning type predicates — the transpiled code passes these through sx_truthy, so they need to return Bool, not OCaml bool. *) diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index 5f23296..0412bd2 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -36,6 +36,7 @@ and value = | Spread of (string * value) list | SxExpr of string (** Opaque SX wire-format string — aser output. *) | Env of env (** First-class environment — used by CEK machine state dicts. *) + | ListRef of value list ref (** Mutable list — JS-style array for append! *) (** Mutable string-keyed table (SX dicts support [dict-set!]). *) and dict = (string, value) Hashtbl.t @@ -117,9 +118,30 @@ let rec env_set env name v = | None -> Hashtbl.replace env.bindings name v; Nil let env_merge base overlay = - let e = { bindings = Hashtbl.copy base.bindings; parent = base.parent } in - Hashtbl.iter (fun k v -> Hashtbl.replace e.bindings k v) overlay.bindings; - e + (* If base and overlay are the same env (physical equality) or overlay + is a descendant of base, just extend base — no copying needed. + This prevents set! inside lambdas from modifying shadow copies. *) + if base == overlay then + { bindings = Hashtbl.create 16; parent = Some base } + else begin + (* Check if overlay is a descendant of base *) + let rec is_descendant e depth = + if depth > 100 then false + else if e == base then true + else match e.parent with Some p -> is_descendant p (depth + 1) | None -> false + in + if is_descendant overlay 0 then + { bindings = Hashtbl.create 16; parent = Some base } + else begin + (* General case: extend base, copy ONLY overlay bindings that don't + exist anywhere in the base chain (avoids shadowing closure bindings). *) + let e = { bindings = Hashtbl.create 16; parent = Some base } in + Hashtbl.iter (fun k v -> + if not (env_has base k) then Hashtbl.replace e.bindings k v + ) overlay.bindings; + e + end + end (** {1 Value extraction helpers} *) @@ -131,7 +153,7 @@ let value_to_string = function | Nil -> "" | _ -> "" let value_to_string_list = function - | List items -> List.map value_to_string items + | List items | ListRef { contents = items } -> List.map value_to_string items | _ -> [] let value_to_bool = function @@ -197,7 +219,7 @@ let type_of = function | String _ -> "string" | Symbol _ -> "symbol" | Keyword _ -> "keyword" - | List _ -> "list" + | List _ | ListRef _ -> "list" | Dict _ -> "dict" | Lambda _ -> "lambda" | Component _ -> "component" @@ -344,7 +366,7 @@ let rec inspect = function | String s -> Printf.sprintf "%S" s | Symbol s -> s | Keyword k -> ":" ^ k - | List items -> + | List items | ListRef { contents = items } -> "(" ^ String.concat " " (List.map inspect items) ^ ")" | Dict d -> let pairs = Hashtbl.fold (fun k v acc -> diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index de233df..00e0dcb 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -318,6 +318,7 @@ (when (and (list? node) (not (empty? node))) (let ((head (first node))) (cond + ;; set! targets (and (= (type-of head) "symbol") (= (symbol-name head) "set!") (>= (len node) 2)) @@ -327,6 +328,15 @@ (let ((mangled (ml-mangle var-name))) (when (not (some (fn (x) (= x mangled)) result)) (append! result mangled)))) + ;; append! targets — need ref wrapping just like set! + (and (= (type-of head) "symbol") + (= (symbol-name head) "append!") + (>= (len node) 2) + (= (type-of (nth node 1)) "symbol")) + (let ((var-name (symbol-name (nth node 1)))) + (let ((mangled (ml-mangle var-name))) + (when (not (some (fn (x) (= x mangled)) result)) + (append! result mangled)))) :else (for-each (fn (child) (when (list? child) @@ -543,8 +553,16 @@ ;; Mutation forms (= op "append!") - (str "(sx_append_b " (ml-expr-inner (nth args 0) set-vars) - " " (ml-expr-inner (nth args 1) set-vars) ")") + (let ((target (nth args 0)) + (item-expr (ml-expr-inner (nth args 1) set-vars))) + (if (and (= (type-of target) "symbol") + (some (fn (v) (= v (ml-mangle (symbol-name target)))) set-vars)) + ;; Target is a ref variable — emit ref mutation + (let ((mangled (ml-mangle (symbol-name target)))) + (str "(" mangled " := sx_append_b !" mangled " " item-expr "; Nil)")) + ;; Not a ref — fallback (returns new list) + (str "(sx_append_b " (ml-expr-inner target set-vars) + " " item-expr ")"))) (= op "dict-set!") (str "(sx_dict_set_b " (ml-expr-inner (nth args 0) set-vars) diff --git a/shared/sx/jinja_bridge.py b/shared/sx/jinja_bridge.py index 27f5ad3..f167703 100644 --- a/shared/sx/jinja_bridge.py +++ b/shared/sx/jinja_bridge.py @@ -31,7 +31,13 @@ from typing import Any from .types import NIL, Component, Island, Keyword, Lambda, Macro, Symbol from .parser import parse import os as _os -if _os.environ.get("SX_USE_REF") == "1": +if _os.environ.get("SX_USE_OCAML") == "1": + # OCaml kernel bridge — render via persistent subprocess. + # html_render and _render_component are set up lazily since the bridge + # requires an async event loop. The sync sx() function falls back to + # the ref renderer; async callers use ocaml_bridge directly. + from .ref.sx_ref import render as html_render, render_html_component as _render_component +elif _os.environ.get("SX_USE_REF") == "1": from .ref.sx_ref import render as html_render, render_html_component as _render_component else: from .html import render as html_render, _render_component @@ -348,6 +354,12 @@ def reload_if_changed() -> None: reload_logger.info("Reloaded %d file(s), components in %.1fms", len(changed_files), (t1 - t0) * 1000) + # Invalidate OCaml bridge component cache so next render reloads + if _os.environ.get("SX_USE_OCAML") == "1": + from .ocaml_bridge import _bridge + if _bridge is not None: + _bridge._components_loaded = False + # Recompute render plans for all services that have pages from .pages import _PAGE_REGISTRY, compute_page_render_plans for svc in _PAGE_REGISTRY: @@ -430,6 +442,9 @@ def finalize_components() -> None: compute_all_io_refs(_COMPONENT_ENV, get_all_io_names()) _compute_component_hash() + # OCaml bridge loads components lazily on first render via + # OcamlBridge._ensure_components() — no sync needed here. + # --------------------------------------------------------------------------- # sx() — render s-expression from Jinja template @@ -482,7 +497,16 @@ async def sx_async(source: str, **kwargs: Any) -> str: Use when the s-expression contains I/O nodes:: {{ sx_async('(frag "blog" "card" :slug "apple")') | safe }} + + When SX_USE_OCAML=1, renders via the OCaml kernel subprocess which + yields io-requests back to Python for async fulfillment. """ + if _os.environ.get("SX_USE_OCAML") == "1": + from .ocaml_bridge import get_bridge + bridge = await get_bridge() + ctx = dict(kwargs) + return await bridge.render(source, ctx=ctx) + from .resolver import resolve, RequestContext env = dict(_COMPONENT_ENV) diff --git a/shared/sx/ocaml_bridge.py b/shared/sx/ocaml_bridge.py new file mode 100644 index 0000000..6d8f29e --- /dev/null +++ b/shared/sx/ocaml_bridge.py @@ -0,0 +1,408 @@ +""" +OCaml SX kernel ↔ Python coroutine bridge. + +Manages a persistent OCaml subprocess (sx_server) that evaluates SX +expressions. When the OCaml kernel needs IO (database queries, service +calls), it yields an ``(io-request ...)`` back to Python, which fulfills +it asynchronously and sends an ``(io-response ...)`` back. + +Usage:: + + bridge = OcamlBridge() + await bridge.start() + html = await bridge.render('(div (p "hello"))') + await bridge.stop() +""" + +from __future__ import annotations + +import asyncio +import logging +import os +from typing import Any + +_logger = logging.getLogger("sx.ocaml") + +# Default binary path — can be overridden via SX_OCAML_BIN env var +_DEFAULT_BIN = os.path.join( + os.path.dirname(__file__), + "../../hosts/ocaml/_build/default/bin/sx_server.exe", +) + + +class OcamlBridgeError(Exception): + """Error from the OCaml SX kernel.""" + + +class OcamlBridge: + """Async bridge to a persistent OCaml SX subprocess.""" + + def __init__(self, binary: str | None = None): + self._binary = binary or os.environ.get("SX_OCAML_BIN") or _DEFAULT_BIN + self._proc: asyncio.subprocess.Process | None = None + self._lock = asyncio.Lock() + self._started = False + self._components_loaded = False + + async def start(self) -> None: + """Launch the OCaml subprocess and wait for (ready).""" + if self._started: + return + + bin_path = os.path.abspath(self._binary) + if not os.path.isfile(bin_path): + raise FileNotFoundError( + f"OCaml SX server binary not found: {bin_path}\n" + f"Build with: cd hosts/ocaml && eval $(opam env) && dune build" + ) + + _logger.info("Starting OCaml SX kernel: %s", bin_path) + self._proc = await asyncio.create_subprocess_exec( + bin_path, + stdin=asyncio.subprocess.PIPE, + stdout=asyncio.subprocess.PIPE, + stderr=asyncio.subprocess.PIPE, + ) + + # Wait for (ready) + line = await self._readline() + if line != "(ready)": + raise OcamlBridgeError(f"Expected (ready), got: {line!r}") + + self._started = True + + # Verify engine identity + self._send("(ping)") + kind, engine = await self._read_response() + engine_name = engine if kind == "ok" else "unknown" + _logger.info("OCaml SX kernel ready (pid=%d, engine=%s)", self._proc.pid, engine_name) + + async def stop(self) -> None: + """Terminate the subprocess.""" + if self._proc and self._proc.returncode is None: + self._proc.stdin.close() + try: + await asyncio.wait_for(self._proc.wait(), timeout=5.0) + except asyncio.TimeoutError: + self._proc.kill() + await self._proc.wait() + _logger.info("OCaml SX kernel stopped") + self._proc = None + self._started = False + + async def ping(self) -> str: + """Health check — returns engine name (e.g. 'ocaml-cek').""" + async with self._lock: + self._send("(ping)") + kind, value = await self._read_response() + return value or "" if kind == "ok" else "" + + async def load(self, path: str) -> int: + """Load an .sx file for side effects (defcomp, define, defmacro).""" + async with self._lock: + self._send(f'(load "{_escape(path)}")') + kind, value = await self._read_response() + if kind == "error": + raise OcamlBridgeError(f"load {path}: {value}") + return int(float(value)) if value else 0 + + async def load_source(self, source: str) -> int: + """Evaluate SX source for side effects.""" + async with self._lock: + self._send(f'(load-source "{_escape(source)}")') + kind, value = await self._read_response() + if kind == "error": + raise OcamlBridgeError(f"load-source: {value}") + return int(float(value)) if value else 0 + + async def eval(self, source: str) -> str: + """Evaluate SX expression, return serialized result.""" + async with self._lock: + self._send(f'(eval "{_escape(source)}")') + kind, value = await self._read_response() + if kind == "error": + raise OcamlBridgeError(f"eval: {value}") + return value or "" + + async def render( + self, + source: str, + ctx: dict[str, Any] | None = None, + ) -> str: + """Render SX to HTML, handling io-requests via Python async IO.""" + await self._ensure_components() + async with self._lock: + self._send(f'(render "{_escape(source)}")') + return await self._read_until_ok(ctx) + + async def _ensure_components(self) -> None: + """Load component definitions into the kernel on first use.""" + if self._components_loaded: + return + self._components_loaded = True + try: + from .jinja_bridge import get_component_env, _CLIENT_LIBRARY_SOURCES + from .parser import serialize + from .types import Component, Island, Macro + + env = get_component_env() + parts: list[str] = list(_CLIENT_LIBRARY_SOURCES) + for key, val in env.items(): + if isinstance(val, Island): + ps = ["&key"] + list(val.params) + if val.has_children: + ps.extend(["&rest", "children"]) + parts.append(f"(defisland ~{val.name} ({' '.join(ps)}) {serialize(val.body)})") + elif isinstance(val, Component): + ps = ["&key"] + list(val.params) + if val.has_children: + ps.extend(["&rest", "children"]) + parts.append(f"(defcomp ~{val.name} ({' '.join(ps)}) {serialize(val.body)})") + elif isinstance(val, Macro): + ps = list(val.params) + if val.rest_param: + ps.extend(["&rest", val.rest_param]) + parts.append(f"(defmacro {val.name} ({' '.join(ps)}) {serialize(val.body)})") + if parts: + source = "\n".join(parts) + await self.load_source(source) + _logger.info("Loaded %d definitions into OCaml kernel", len(parts)) + except Exception as e: + _logger.error("Failed to load components into OCaml kernel: %s", e) + self._components_loaded = False # retry next time + + async def reset(self) -> None: + """Reset the kernel environment to pristine state.""" + async with self._lock: + self._send("(reset)") + kind, value = await self._read_response() + if kind == "error": + raise OcamlBridgeError(f"reset: {value}") + + # ------------------------------------------------------------------ + # Internal protocol handling + # ------------------------------------------------------------------ + + def _send(self, line: str) -> None: + """Write a line to the subprocess stdin.""" + assert self._proc and self._proc.stdin + self._proc.stdin.write((line + "\n").encode()) + + async def _readline(self) -> str: + """Read a line from the subprocess stdout.""" + assert self._proc and self._proc.stdout + data = await self._proc.stdout.readline() + if not data: + # Process died — collect stderr for diagnostics + stderr = b"" + if self._proc.stderr: + stderr = await self._proc.stderr.read() + raise OcamlBridgeError( + f"OCaml subprocess died unexpectedly. stderr: {stderr.decode(errors='replace')}" + ) + return data.decode().rstrip("\n") + + async def _read_response(self) -> tuple[str, str | None]: + """Read a single (ok ...) or (error ...) response. + + Returns (kind, value) where kind is "ok" or "error". + """ + line = await self._readline() + return _parse_response(line) + + async def _read_until_ok( + self, + ctx: dict[str, Any] | None = None, + ) -> str: + """Read lines until (ok ...) or (error ...). + + Handles (io-request ...) by fulfilling IO and sending (io-response ...). + """ + while True: + line = await self._readline() + + if line.startswith("(io-request "): + result = await self._handle_io_request(line, ctx) + # Send response back to OCaml + self._send(f"(io-response {_serialize_for_ocaml(result)})") + continue + + kind, value = _parse_response(line) + if kind == "error": + raise OcamlBridgeError(value or "Unknown error") + # kind == "ok" + return value or "" + + async def _handle_io_request( + self, + line: str, + ctx: dict[str, Any] | None, + ) -> Any: + """Dispatch an io-request to the appropriate Python handler.""" + from .parser import parse_all + + # Parse the io-request + parsed = parse_all(line) + if not parsed or not isinstance(parsed[0], list): + raise OcamlBridgeError(f"Malformed io-request: {line}") + + parts = parsed[0] + # parts = [Symbol("io-request"), name_str, ...args] + if len(parts) < 2: + raise OcamlBridgeError(f"Malformed io-request: {line}") + + req_name = _to_str(parts[1]) + args = parts[2:] + + if req_name == "query": + return await self._io_query(args) + elif req_name == "action": + return await self._io_action(args) + elif req_name == "request-arg": + return self._io_request_arg(args) + elif req_name == "request-method": + return self._io_request_method() + elif req_name == "ctx": + return self._io_ctx(args, ctx) + else: + raise OcamlBridgeError(f"Unknown io-request type: {req_name}") + + async def _io_query(self, args: list) -> Any: + """Handle (io-request "query" service name params...).""" + from shared.infrastructure.internal import fetch_data + + service = _to_str(args[0]) if len(args) > 0 else "" + query = _to_str(args[1]) if len(args) > 1 else "" + params = _to_dict(args[2]) if len(args) > 2 else {} + return await fetch_data(service, query, params) + + async def _io_action(self, args: list) -> Any: + """Handle (io-request "action" service name payload...).""" + from shared.infrastructure.internal import call_action + + service = _to_str(args[0]) if len(args) > 0 else "" + action = _to_str(args[1]) if len(args) > 1 else "" + payload = _to_dict(args[2]) if len(args) > 2 else {} + return await call_action(service, action, payload) + + def _io_request_arg(self, args: list) -> Any: + """Handle (io-request "request-arg" name).""" + try: + from quart import request + name = _to_str(args[0]) if args else "" + return request.args.get(name) + except RuntimeError: + return None + + def _io_request_method(self) -> str: + """Handle (io-request "request-method").""" + try: + from quart import request + return request.method + except RuntimeError: + return "GET" + + def _io_ctx(self, args: list, ctx: dict[str, Any] | None) -> Any: + """Handle (io-request "ctx" key).""" + if ctx is None: + return None + key = _to_str(args[0]) if args else "" + return ctx.get(key) + + +# ------------------------------------------------------------------ +# Module-level singleton +# ------------------------------------------------------------------ + +_bridge: OcamlBridge | None = None + + +async def get_bridge() -> OcamlBridge: + """Get or create the singleton bridge instance.""" + global _bridge + if _bridge is None: + _bridge = OcamlBridge() + if not _bridge._started: + await _bridge.start() + return _bridge + + +# ------------------------------------------------------------------ +# Helpers +# ------------------------------------------------------------------ + +def _escape(s: str) -> str: + """Escape a string for embedding in an SX string literal.""" + return s.replace("\\", "\\\\").replace('"', '\\"').replace("\n", "\\n").replace("\r", "\\r").replace("\t", "\\t") + + +def _parse_response(line: str) -> tuple[str, str | None]: + """Parse an (ok ...) or (error ...) response line. + + Returns (kind, value) tuple. + """ + line = line.strip() + if line == "(ok)": + return ("ok", None) + if line.startswith("(ok "): + value = line[4:-1] # strip (ok and ) + # If the value is a quoted string, unquote it + if value.startswith('"') and value.endswith('"'): + value = _unescape(value[1:-1]) + return ("ok", value) + if line.startswith("(error "): + msg = line[7:-1] + if msg.startswith('"') and msg.endswith('"'): + msg = _unescape(msg[1:-1]) + return ("error", msg) + return ("error", f"Unexpected response: {line}") + + +def _unescape(s: str) -> str: + """Unescape an SX string literal.""" + return ( + s.replace("\\n", "\n") + .replace("\\r", "\r") + .replace("\\t", "\t") + .replace('\\"', '"') + .replace("\\\\", "\\") + ) + + +def _to_str(val: Any) -> str: + """Convert an SX parsed value to a Python string.""" + if isinstance(val, str): + return val + if hasattr(val, "name"): + return val.name + return str(val) + + +def _to_dict(val: Any) -> dict: + """Convert an SX parsed value to a Python dict.""" + if isinstance(val, dict): + return val + return {} + + +def _serialize_for_ocaml(val: Any) -> str: + """Serialize a Python value to SX text for sending to OCaml.""" + if val is None: + return "nil" + if isinstance(val, bool): + return "true" if val else "false" + if isinstance(val, (int, float)): + if isinstance(val, float) and val == int(val): + return str(int(val)) + return str(val) + if isinstance(val, str): + return f'"{_escape(val)}"' + if isinstance(val, (list, tuple)): + items = " ".join(_serialize_for_ocaml(v) for v in val) + return f"(list {items})" + if isinstance(val, dict): + pairs = " ".join( + f":{k} {_serialize_for_ocaml(v)}" for k, v in val.items() + ) + return "{" + pairs + "}" + return f'"{_escape(str(val))}"' diff --git a/shared/sx/tests/test_ocaml_bridge.py b/shared/sx/tests/test_ocaml_bridge.py new file mode 100644 index 0000000..aa2a0a0 --- /dev/null +++ b/shared/sx/tests/test_ocaml_bridge.py @@ -0,0 +1,220 @@ +"""Tests for the OCaml SX bridge.""" + +import asyncio +import os +import sys +import unittest + +# Add project root to path +_project_root = os.path.abspath(os.path.join(os.path.dirname(__file__), "../../..")) +if _project_root not in sys.path: + sys.path.insert(0, _project_root) + +from shared.sx.ocaml_bridge import OcamlBridge, OcamlBridgeError, _escape, _parse_response, _serialize_for_ocaml + + +class TestHelpers(unittest.TestCase): + """Test helper functions (no subprocess needed).""" + + def test_escape_basic(self): + self.assertEqual(_escape('hello'), 'hello') + self.assertEqual(_escape('say "hi"'), 'say \\"hi\\"') + self.assertEqual(_escape('a\\b'), 'a\\\\b') + self.assertEqual(_escape('line\nbreak'), 'line\\nbreak') + + def test_parse_response_ok_empty(self): + self.assertEqual(_parse_response("(ok)"), ("ok", None)) + + def test_parse_response_ok_number(self): + self.assertEqual(_parse_response("(ok 3)"), ("ok", "3")) + + def test_parse_response_ok_string(self): + kind, val = _parse_response('(ok "
hi
")') + self.assertEqual(kind, "ok") + self.assertEqual(val, "
hi
") + + def test_parse_response_error(self): + kind, val = _parse_response('(error "something broke")') + self.assertEqual(kind, "error") + self.assertEqual(val, "something broke") + + def test_serialize_none(self): + self.assertEqual(_serialize_for_ocaml(None), "nil") + + def test_serialize_bool(self): + self.assertEqual(_serialize_for_ocaml(True), "true") + self.assertEqual(_serialize_for_ocaml(False), "false") + + def test_serialize_number(self): + self.assertEqual(_serialize_for_ocaml(42), "42") + self.assertEqual(_serialize_for_ocaml(3.14), "3.14") + + def test_serialize_string(self): + self.assertEqual(_serialize_for_ocaml("hello"), '"hello"') + self.assertEqual(_serialize_for_ocaml('say "hi"'), '"say \\"hi\\""') + + def test_serialize_list(self): + self.assertEqual(_serialize_for_ocaml([1, 2, 3]), "(list 1 2 3)") + + def test_serialize_dict(self): + result = _serialize_for_ocaml({"a": 1}) + self.assertEqual(result, "{:a 1}") + + +class TestBridge(unittest.IsolatedAsyncioTestCase): + """Integration tests — require the OCaml binary to be built.""" + + @classmethod + def setUpClass(cls): + # Check if binary exists + from shared.sx.ocaml_bridge import _DEFAULT_BIN + bin_path = os.path.abspath(_DEFAULT_BIN) + if not os.path.isfile(bin_path): + raise unittest.SkipTest( + f"OCaml binary not found at {bin_path}. " + f"Build with: cd hosts/ocaml && eval $(opam env) && dune build" + ) + + async def asyncSetUp(self): + self.bridge = OcamlBridge() + await self.bridge.start() + + async def asyncTearDown(self): + await self.bridge.stop() + + async def test_ping(self): + self.assertTrue(await self.bridge.ping()) + + async def test_eval_arithmetic(self): + result = await self.bridge.eval("(+ 1 2)") + self.assertEqual(result, "3") + + async def test_eval_string(self): + result = await self.bridge.eval('(str "hello" " " "world")') + self.assertIn("hello world", result) + + async def test_render_simple(self): + html = await self.bridge.render('(div (p "hello"))') + self.assertEqual(html, "

hello

") + + async def test_render_attrs(self): + html = await self.bridge.render('(div :class "card" (p "hi"))') + self.assertIn('class="card"', html) + self.assertIn("

hi

", html) + + async def test_render_void_element(self): + html = await self.bridge.render("(br)") + self.assertEqual(html, "
") + + async def test_load_source_defcomp(self): + count = await self.bridge.load_source( + '(defcomp ~test-card (&key title) (div :class "card" (h2 title)))' + ) + self.assertEqual(count, 1) + html = await self.bridge.render('(~test-card :title "Hello")') + self.assertIn("Hello", html) + self.assertIn("card", html) + + async def test_reset(self): + await self.bridge.load_source("(define x 42)") + result = await self.bridge.eval("x") + self.assertEqual(result, "42") + await self.bridge.reset() + with self.assertRaises(OcamlBridgeError): + await self.bridge.eval("x") + + async def test_render_conditional(self): + html = await self.bridge.render('(if true (p "yes") (p "no"))') + self.assertEqual(html, "

yes

") + + async def test_render_let(self): + html = await self.bridge.render('(let (x "hi") (p x))') + self.assertEqual(html, "

hi

") + + async def test_render_map(self): + html = await self.bridge.render( + "(map (lambda (x) (li x)) (list \"a\" \"b\" \"c\"))" + ) + self.assertEqual(html, "
  • a
  • b
  • c
    • ") + + async def test_render_fragment(self): + html = await self.bridge.render('(<> (p "a") (p "b"))') + self.assertEqual(html, "

    a

    b

    ") + + async def test_eval_error(self): + with self.assertRaises(OcamlBridgeError): + await self.bridge.eval("(undefined-symbol-xyz)") + + async def test_render_component_with_children(self): + await self.bridge.load_source( + '(defcomp ~wrapper (&rest children) (div :class "wrap" children))' + ) + html = await self.bridge.render('(~wrapper (p "inside"))') + self.assertIn("wrap", html) + self.assertIn("

    inside

    ", html) + + async def test_render_macro(self): + await self.bridge.load_source( + "(defmacro unless (cond &rest body) (list 'if (list 'not cond) (cons 'do body)))" + ) + html = await self.bridge.render('(unless false (p "shown"))') + self.assertEqual(html, "

    shown

    ") + + # ------------------------------------------------------------------ + # ListRef regression tests — the `list` primitive returns ListRef + # (mutable), not List (immutable). Macro expansions that construct + # AST via `list` produce ListRef nodes. The renderer must handle + # both List and ListRef at every structural match point. + # ------------------------------------------------------------------ + + async def test_render_macro_generates_cond(self): + """Macro that programmatically builds a (cond ...) with list.""" + await self.bridge.load_source( + "(defmacro pick (x) " + " (list 'cond " + " (list (list '= x 1) '(p \"one\")) " + " (list (list '= x 2) '(p \"two\")) " + " (list ':else '(p \"other\"))))" + ) + html = await self.bridge.render("(pick 2)") + self.assertEqual(html, "

    two

    ") + + async def test_render_macro_generates_let(self): + """Macro that programmatically builds a (let ...) with list.""" + await self.bridge.load_source( + "(defmacro with-greeting (name &rest body) " + " (list 'let (list (list 'greeting (list 'str \"Hello \" name))) " + " (cons 'do body)))" + ) + html = await self.bridge.render('(with-greeting "World" (p greeting))') + self.assertEqual(html, "

    Hello World

    ") + + async def test_render_macro_nested_html_tags(self): + """Macro expansion containing nested HTML tags via list.""" + await self.bridge.load_source( + "(defmacro card (title &rest body) " + " (list 'div ':class \"card\" " + " (list 'h2 title) " + " (cons 'do body)))" + ) + html = await self.bridge.render('(card "Title" (p "content"))') + self.assertIn('
    ', html) + self.assertIn("

    Title

    ", html) + self.assertIn("

    content

    ", html) + + async def test_render_eval_returns_listref(self): + """Values created at runtime via (list ...) are ListRef.""" + await self.bridge.load_source( + "(define make-items (lambda () (list " + ' (list "a") (list "b") (list "c"))))' + ) + html = await self.bridge.render( + "(ul (map (lambda (x) (li (first x))) (make-items)))" + ) + self.assertIn("
  • a
    • ", html) + self.assertIn("
  • b
    • ", html) + self.assertIn("
  • c
    • ", html) + + +if __name__ == "__main__": + unittest.main() diff --git a/sx/app.py b/sx/app.py index e1f51ed..3793457 100644 --- a/sx/app.py +++ b/sx/app.py @@ -148,6 +148,21 @@ def create_app() -> "Quart": target = path + "/" + ("?" + qs if qs else "") return redirect(target, 301) + @app.get("/sx/_engine") + async def sx_engine_info(): + """Diagnostic: which SX engine is active.""" + import os, json + info = {"engine": "python-ref", "ocaml": False} + if os.environ.get("SX_USE_OCAML") == "1": + try: + from shared.sx.ocaml_bridge import get_bridge + bridge = await get_bridge() + engine = await bridge.ping() + info = {"engine": engine, "ocaml": True, "pid": bridge._proc.pid} + except Exception as e: + info = {"engine": "ocaml-error", "ocaml": False, "error": str(e)} + return json.dumps(info), 200, {"Content-Type": "application/json"} + @app.get("/sx/") async def sx_home(): """SX docs home page.""" diff --git a/sx/sx/plans/foundations.sx b/sx/sx/plans/foundations.sx index 224ed93..334b458 100644 --- a/sx/sx/plans/foundations.sx +++ b/sx/sx/plans/foundations.sx @@ -231,15 +231,135 @@ (tr (td :class "pr-4 py-1" "3") (td :class "pr-4" "Content-addressed computation") (td :class "text-emerald-600 font-semibold" "\u2714 Done \u2014 content-hash, freeze-to-cid, thaw-from-cid")) + (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" "4") (td :class "pr-4" "Concurrent CEK") - (td :class "text-amber-600 font-semibold" "Spec complete \u2014 implementation next")) + (td :class "text-amber-600 font-semibold" "Spec complete — implementation next")) (tr (td :class "pr-4 py-1" "5") (td :class "pr-4" "Linear effects") (td :class "text-stone-400" "Future"))))) ;; ----------------------------------------------------------------------- - ;; Step 4: Concurrent CEK \u2014 deep spec + ;; Step 3.5: Data Representations + ;; ----------------------------------------------------------------------- + + (h2 :class "text-xl font-bold mt-12 mb-4" "Step 3.5: Data Representations") + + (p "Two primitives that sit below concurrency but above the raw CEK machine. " + "Both are about how values are represented — enabling work that's currently host-only.") + + (h3 :class "text-lg font-semibold mt-8 mb-3" "3.5a Byte Buffers") + + (p "Fixed-size mutable byte arrays. A small primitive surface that unlocks " + "binary protocol parsing, image headers, wire formats, and efficient CID computation:") + + (~docs/code :code + (str ";; Create and write\n" + "(let ((buf (make-buffer 256)))\n" + " (buffer-write-u8! buf 0 #xFF)\n" + " (buffer-write-u32! buf 1 magic-number)\n" + " (buffer-slice buf 0 5))\n" + "\n" + ";; Read from network/file\n" + "(let ((header (buffer-slice packet 0 12)))\n" + " (case (buffer-read-u8 header 0)\n" + " (1 (parse-handshake header))\n" + " (2 (parse-data header))\n" + " (else (error \"unknown packet type\"))))")) + + (p "Primitives:") + + (ul :class "list-disc pl-6 mb-4 space-y-1" + (li (code "make-buffer") " — allocate N zero-filled bytes") + (li (code "buffer-read-u8/u16/u32") ", " (code "buffer-read-i8/i16/i32") " — typed reads at offset") + (li (code "buffer-write-u8!/u16!/u32!") " — typed writes at offset (big-endian default)") + (li (code "buffer-slice") " — zero-copy view of a region") + (li (code "buffer-length") " — byte count") + (li (code "buffer->list") ", " (code "list->buffer") " — conversion to/from byte lists") + (li (code "buffer->string") ", " (code "string->buffer") " — UTF-8 encode/decode")) + + (p "Host mapping:") + + (div :class "overflow-x-auto mb-6" + (table :class "min-w-full text-sm" + (thead (tr + (th :class "text-left pr-4 pb-2 font-semibold" "Primitive") + (th :class "text-left pr-4 pb-2 font-semibold" "JavaScript") + (th :class "text-left pr-4 pb-2 font-semibold" "Python") + (th :class "text-left pb-2 font-semibold" "OCaml"))) + (tbody + (tr (td :class "pr-4 py-1 font-mono" "make-buffer") + (td :class "pr-4" "new ArrayBuffer(n)") + (td :class "pr-4" "bytearray(n)") + (td "Bytes.create n")) + (tr (td :class "pr-4 py-1 font-mono" "buffer-read-u32") + (td :class "pr-4" "DataView.getUint32") + (td :class "pr-4" "struct.unpack_from") + (td "Bytes.get_int32_be")) + (tr (td :class "pr-4 py-1 font-mono" "buffer-slice") + (td :class "pr-4" "new Uint8Array(buf, off, len)") + (td :class "pr-4" "memoryview(buf)[off:off+len]") + (td "Bytes.sub buf off len"))))) + + (p "Byte buffers connect directly to content addressing (Step 3). " + "Computing a CID currently requires host-side hashing of opaque SX text. " + "With buffers, the hash input can be a canonical binary representation — " + "deterministic, compact, and consistent across hosts.") + + (h3 :class "text-lg font-semibold mt-8 mb-3" "3.5b Typed Structs") + + (p "Named product types with fixed fields. On interpreted hosts, structs are syntactic sugar over dicts. " + "On compiled hosts (OCaml, Rust), they compile to unboxed records — no dict overhead, " + "no hash lookups, no string key comparisons:") + + (~docs/code :code + (str ";; Define a struct\n" + "(defstruct point (x : number) (y : number))\n" + "\n" + ";; Construct\n" + "(let ((p (make-point 3 4)))\n" + " ;; Access — compiles to field offset on native hosts\n" + " (+ (point-x p) (point-y p))) ;; => 7\n" + "\n" + ";; Pattern match\n" + "(case p\n" + " ((point x y) (sqrt (+ (* x x) (* y y))))) ;; => 5")) + + (p "What " (code "defstruct") " generates:") + + (ul :class "list-disc pl-6 mb-4 space-y-1" + (li (code "make-point") " — constructor (arity-checked)") + (li (code "point?") " — type predicate") + (li (code "point-x") ", " (code "point-y") " — field accessors") + (li (code "point") " — case pattern for destructuring")) + + (p "The performance difference matters for compiled hosts:") + + (div :class "overflow-x-auto mb-6" + (table :class "min-w-full text-sm" + (thead (tr + (th :class "text-left pr-4 pb-2 font-semibold" "Operation") + (th :class "text-left pr-4 pb-2 font-semibold" "Dict (current)") + (th :class "text-left pb-2 font-semibold" "Struct (compiled)"))) + (tbody + (tr (td :class "pr-4 py-1" "Field access") + (td :class "pr-4" "Hash lookup — O(1) amortized, cache-unfriendly") + (td "Offset load — O(1) actual, single instruction")) + (tr (td :class "pr-4 py-1" "Construction") + (td :class "pr-4" "Allocate hash table + insert N entries") + (td "Allocate N words, write sequentially")) + (tr (td :class "pr-4 py-1" "Pattern match") + (td :class "pr-4" "N string comparisons") + (td "Tag check + field projection"))))) + + (p "Typed structs connect to the gradual type system in " (code "types.sx") ". " + "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 4: Concurrent CEK — deep spec ;; ----------------------------------------------------------------------- (h2 :class "text-xl font-bold mt-12 mb-4" "Step 4: Concurrent CEK") @@ -449,33 +569,33 @@ (th :class "text-left pr-4 pb-2 font-semibold" "Primitive") (th :class "text-left pr-4 pb-2 font-semibold" "JavaScript") (th :class "text-left pr-4 pb-2 font-semibold" "Python") - (th :class "text-left pr-4 pb-2 font-semibold" "Haskell") + (th :class "text-left pr-4 pb-2 font-semibold" "OCaml") (th :class "text-left pb-2 font-semibold" "Rust/WASM"))) (tbody (tr (td :class "pr-4 py-1 font-mono" "spawn") (td :class "pr-4" "Web Worker") (td :class "pr-4" "asyncio.create_task") - (td :class "pr-4" "forkIO") + (td :class "pr-4" "Eio.Fiber.fork") (td "tokio::spawn")) (tr (td :class "pr-4 py-1 font-mono" "channel") (td :class "pr-4" "MessageChannel") (td :class "pr-4" "asyncio.Queue") - (td :class "pr-4" "TChan (STM)") + (td :class "pr-4" "Eio.Stream.t") (td "mpsc::channel")) (tr (td :class "pr-4 py-1 font-mono" "yield!") (td :class "pr-4" "setTimeout(0)") (td :class "pr-4" "await asyncio.sleep(0)") - (td :class "pr-4" "threadDelay 0") + (td :class "pr-4" "Eio.Fiber.yield") (td "tokio::task::yield_now")) (tr (td :class "pr-4 py-1 font-mono" "freeze/thaw") (td :class "pr-4" "postMessage + JSON") (td :class "pr-4" "pickle / SX text") - (td :class "pr-4" "Serialise + SX text") + (td :class "pr-4" "Marshal + SX text") (td "serde + SX text")) (tr (td :class "pr-4 py-1 font-mono" "select") (td :class "pr-4" "Promise.race") (td :class "pr-4" "asyncio.wait FIRST_COMPLETED") - (td :class "pr-4" "STM orElse") + (td :class "pr-4" "Eio.Fiber.any") (td "tokio::select!"))))) (h3 :class "text-lg font-semibold mt-8 mb-3" "4.7 Roadmap") @@ -501,9 +621,9 @@ (td :class "pr-4" "JavaScript") (td "Art DAG integration path")) (tr (td :class "pr-4 py-1" "4d") - (td :class "pr-4" "Haskell bootstrapper") - (td :class "pr-4" "Haskell") - (td "Spec portability, native concurrency")) + (td :class "pr-4" "OCaml bootstrapper → native compilation") + (td :class "pr-4" "OCaml") + (td "Native performance, direct CEK-to-ML mapping")) (tr (td :class "pr-4 py-1" "4e") (td :class "pr-4" "Rust/WASM bootstrapper") (td :class "pr-4" "Rust") @@ -526,8 +646,8 @@ (td "Resource safety, exactly-once delivery"))))) (p "Each phase is independently valuable. Phase 4a (Web Worker spawn) is the immediate next build. " - "Phase 4d (Haskell) proves the spec is truly host-independent. " - "Phase 4e (Rust/WASM) proves it can be fast. " + "Phase 4d (OCaml) proves the spec compiles to native code — the CEK machine maps directly to ML's runtime model. " + "Phase 4e (Rust/WASM) proves it can run in the browser at near-native speed. " "Phase 4g (IPFS) makes it distributed.") ;; -----------------------------------------------------------------------