From f814193c9403bcfb7970865ad36eb6e616fc6be7 Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 4 Apr 2026 14:03:00 +0000 Subject: [PATCH] Step 7a WIP: ->> and as-> pipe operators (thread-last has transpiler bug) Add to evaluator.sx: - step-sf-thread-last: thread-last operator (inserts value at end) - step-sf-thread-as: thread-anywhere with named binding - thread-insert-arg-last: last-position insertion function - step-sf-case: missing function (was in old transpiled output but not spec) - Register ->>, |>, as-> in step-eval-list dispatch Status: - ->> dispatch works (enters thread-last correctly) - HO forms (map, filter) with ->> work correctly - Non-HO forms with ->> still use thread-first (transpiler bug) - as-> binding fails (related transpiler bug) Transpiler bug: thread_insert_arg_last definition body is merged with step_continue in the let rec block. The transpiler incorrectly chains them as one function. Need to investigate the let rec emission logic. 2644 tests still pass (no regressions from new operators). Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/lib/sx_ref.ml | 82 ++++- spec/evaluator.sx | 730 ++++++++++++++++++++++++++++++-------- 2 files changed, 655 insertions(+), 157 deletions(-) diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index f1bde717..ece7a0cd 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -110,13 +110,17 @@ and make_case_frame match_val remaining env = (CekFrame { cf_type = "case"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = match_val; cf_extra2 = Nil }) (* make-thread-frame *) -and make_thread_frame remaining env = - (CekFrame { cf_type = "thread"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) +and make_thread_frame remaining env mode name = + (CekFrame { cf_type = "thread"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) (* thread-insert-arg *) and thread_insert_arg form value fenv = (if sx_truthy ((prim_call "=" [(type_of (form)); (String "list")])) then (eval_expr ((cons ((first (form))) ((cons ((List [(Symbol "quote"); value])) ((rest (form))))))) (fenv)) else (eval_expr ((List [form; (List [(Symbol "quote"); value])])) (fenv))) +(* thread-insert-arg-last *) +and thread_insert_arg_last form value fenv = + (if sx_truthy ((prim_call "=" [(type_of (form)); (String "list")])) then (eval_expr ((prim_call "append" [form; (List [(List [(Symbol "quote"); value])])])) (fenv)) else (eval_expr ((List [form; (List [(Symbol "quote"); value])])) (fenv))) + (* make-map-frame *) and make_map_frame f remaining results env = (CekFrame { cf_type = "map"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = results; cf_extra = (Bool false); cf_extra2 = Nil }) @@ -237,6 +241,10 @@ and make_vm_resume_frame resume_fn env = and make_import_frame import_set remaining_sets env = (CekFrame { cf_type = "import"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining_sets; cf_f = Nil; cf_args = import_set; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) +(* make-parameterize-frame *) +and make_parameterize_frame remaining current_param results body env = + (CekFrame { cf_type = "parameterize"; cf_env = env; cf_name = Nil; cf_body = body; cf_remaining = remaining; cf_f = current_param; cf_args = Nil; cf_results = results; cf_extra = Nil; cf_extra2 = Nil }) + (* find-matching-handler *) and find_matching_handler handlers condition = (if sx_truthy ((empty_p (handlers))) then Nil else (let pair = (first (handlers)) in (let pred = (first (pair)) in let handler_fn = (nth (pair) ((Number 1.0))) in (if sx_truthy ((cek_call (pred) ((List [condition])))) then handler_fn else (find_matching_handler ((rest (handlers))) (condition)))))) @@ -277,6 +285,10 @@ and kont_empty_p kont = and kont_capture_to_reset kont = (let rec scan = (fun k captured -> (if sx_truthy ((empty_p (k))) then (raise (Eval_error (value_to_str (String "shift without enclosing reset")))) else (let frame = (first (k)) in (if sx_truthy ((let _or = (prim_call "=" [(frame_type (frame)); (String "reset")]) in if sx_truthy _or then _or else (prim_call "=" [(frame_type (frame)); (String "reactive-reset")]))) then (List [captured; (rest (k))]) else (scan ((rest (k))) ((prim_call "append" [captured; (List [frame])]))))))) in (scan (kont) ((List [])))) +(* kont-push-provides *) +and kont_push_provides pairs env kont = + (if sx_truthy ((empty_p (pairs))) then kont else (let pair = (first (pairs)) in (kont_push_provides ((rest (pairs))) (env) ((cons ((make_provide_frame ((first (pair))) ((nth (pair) ((Number 1.0)))) ((List [])) (env))) (kont)))))) + (* kont-find-provide *) and kont_find_provide kont name = (if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((let _and = (prim_call "=" [(frame_type (frame)); (String "provide")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(get (frame) ((String "name"))); name]))) then frame else (kont_find_provide ((rest (kont))) (name))))) @@ -467,7 +479,7 @@ and sf_provide args env = (* expand-macro *) and expand_macro mac raw_args env = - (let local = (env_merge ((macro_closure (mac))) (env)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (if sx_truthy ((prim_call "<" [(nth (pair) ((Number 1.0))); (len (raw_args))])) then (nth (raw_args) ((nth (pair) ((Number 1.0))))) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [p; i])) (sx_to_list (macro_params (mac)))))); Nil)) in (let () = ignore ((if sx_truthy ((macro_rest_param (mac))) then (env_bind local (sx_to_string (macro_rest_param (mac))) (prim_call "slice" [raw_args; (len ((macro_params (mac))))])) else Nil)) in (trampoline ((eval_expr ((macro_body (mac))) (local))))))) + (let body = (macro_body (mac)) in (if sx_truthy ((let _and = (symbol_p (body)) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (body)); (String "__syntax-rules-body__")]))) then (let closure = (macro_closure (mac)) in (syntax_rules_expand ((env_get (closure) ((String "__sr-literals")))) ((env_get (closure) ((String "__sr-rules")))) (raw_args))) else (let local = (env_merge ((macro_closure (mac))) (env)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (if sx_truthy ((prim_call "<" [(nth (pair) ((Number 1.0))); (len (raw_args))])) then (nth (raw_args) ((nth (pair) ((Number 1.0))))) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [p; i])) (sx_to_list (macro_params (mac)))))); Nil)) in (let () = ignore ((if sx_truthy ((macro_rest_param (mac))) then (env_bind local (sx_to_string (macro_rest_param (mac))) (prim_call "slice" [raw_args; (len ((macro_params (mac))))])) else Nil)) in (trampoline ((eval_expr ((macro_body (mac))) (local))))))))) (* cek-step-loop *) and cek_step_loop state = @@ -497,9 +509,53 @@ and step_sf_raise args env kont = and step_sf_guard args env kont = (let var_clauses = (first (args)) in let body = (rest (args)) in let var = (first (var_clauses)) in let clauses = (rest (var_clauses)) in let sentinel = (make_symbol ((String "__guard-reraise__"))) in (step_eval_list ((List [(Symbol "let"); (List [(List [(Symbol "__guard-result"); (cons ((Symbol "call/cc")) ((List [(cons ((Symbol "fn")) ((cons ((List [(Symbol "__guard-k")])) ((List [(cons ((Symbol "handler-bind")) ((cons ((List [(List [(cons ((Symbol "fn")) ((cons ((List [(Symbol "_")])) ((List [(Bool true)]))))); (cons ((Symbol "fn")) ((cons ((List [var])) ((List [(List [(Symbol "__guard-k"); (cons ((Symbol "cond")) ((prim_call "append" [clauses; (List [(List [(Symbol "else"); (List [(Symbol "list"); (List [(Symbol "quote"); sentinel]); var])])])])))])])))))])])) ((List [(List [(Symbol "__guard-k"); (cons ((Symbol "begin")) (body))])])))))])))))])))])]); (List [(Symbol "if"); (List [(Symbol "and"); (List [(Symbol "list?"); (Symbol "__guard-result")]); (List [(Symbol "="); (List [(Symbol "len"); (Symbol "__guard-result")]); (Number 2.0)]); (List [(Symbol "="); (List [(Symbol "first"); (Symbol "__guard-result")]); (List [(Symbol "quote"); sentinel])])]); (List [(Symbol "raise"); (List [(Symbol "nth"); (Symbol "__guard-result"); (Number 1.0)])]); (Symbol "__guard-result")])])) (env) (kont))) +(* step-sf-case *) +and step_sf_case args env kont = + (make_cek_state ((first (args))) (env) ((kont_push ((make_case_frame (Nil) ((rest (args))) (env))) (kont)))) + (* step-eval-list *) and step_eval_list expr env kont = - (let head = (first (expr)) in let args = (rest (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((let _or = (prim_call "=" [(type_of (head)); (String "symbol")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [(type_of (head)); (String "lambda")]) in if sx_truthy _or then _or else (prim_call "=" [(type_of (head)); (String "list")])))))))) then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (make_cek_state ((first (expr))) (env) ((kont_push ((make_map_frame (Nil) ((rest (expr))) ((List [])) (env))) (kont))))) else (if sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])) then (let name = (symbol_name (head)) in (let _match_val = name in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (step_sf_if (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (step_sf_when (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (step_sf_cond (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (step_sf_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (step_sf_and (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (step_sf_or (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let*")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "lambda")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "fn")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defcomp")])) then (make_cek_value ((sf_defcomp (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defisland")])) then (make_cek_value ((sf_defisland (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defmacro")])) then (make_cek_value ((sf_defmacro (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defio")])) then (make_cek_value ((sf_defio (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "io")])) then (step_sf_io (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "do")])) then (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (args)))))) in if not (sx_truthy _and) then _and else (let _and = (list_p ((first (args)))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p ((first (args)))))))) in if not (sx_truthy _and) then _and else (list_p ((first ((first (args)))))))))) then (let bindings = (first (args)) in let test_clause = (nth (args) ((Number 1.0))) in let body = (rest ((rest (args)))) in let vars = (List (List.map (fun b -> (first (b))) (sx_to_list bindings))) in let inits = (List (List.map (fun b -> (nth (b) ((Number 1.0)))) (sx_to_list bindings))) in let steps = (List (List.map (fun b -> (if sx_truthy ((prim_call ">" [(len (b)); (Number 2.0)])) then (nth (b) ((Number 2.0))) else (first (b)))) (sx_to_list bindings))) in let test = (first (test_clause)) in let result' = (rest (test_clause)) in (step_eval_list ((cons ((Symbol "let")) ((cons ((Symbol "__do-loop")) ((cons ((List (List.map (fun b -> (List [(first (b)); (nth (b) ((Number 1.0)))])) (sx_to_list bindings)))) ((List [(cons ((Symbol "if")) ((cons (test) ((cons ((if sx_truthy ((empty_p (result'))) then Nil else (cons ((Symbol "begin")) (result')))) ((List [(cons ((Symbol "begin")) ((prim_call "append" [body; (List [(cons ((Symbol "__do-loop")) (steps))])])))])))))))])))))))) (env) (kont))) else (step_sf_begin (args) (env) (kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "guard")])) then (step_sf_guard (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "quote")])) then (make_cek_value ((if sx_truthy ((empty_p (args))) then Nil else (first (args)))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "quasiquote")])) then (make_cek_value ((qq_expand ((first (args))) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "->")])) then (step_sf_thread_first (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "set!")])) then (step_sf_set_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "letrec")])) then (step_sf_letrec (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (step_sf_reset (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "shift")])) then (step_sf_shift (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (step_sf_deref (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (step_sf_scope (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (step_sf_provide (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler-bind")])) then (step_sf_handler_bind (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart-case")])) then (step_sf_restart_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-condition")])) then (step_sf_signal (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "invoke-restart")])) then (step_sf_invoke_restart (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "match")])) then (step_sf_match (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "dynamic-wind")])) then (make_cek_value ((sf_dynamic_wind (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (step_ho_map (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (step_ho_map_indexed (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (step_ho_filter (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (step_ho_reduce (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (step_ho_some (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "every?")])) then (step_ho_every (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (step_ho_for_each (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise")])) then (step_sf_raise (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-continuable")])) then (make_cek_state ((first (args))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool true)))) (kont)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "call/cc")])) then (step_sf_callcc (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "call-with-current-continuation")])) then (step_sf_callcc (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (step_sf_perform (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-library")])) then (step_sf_define_library (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (step_sf_import (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-record-type")])) then (make_cek_value ((sf_define_record_type (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "has-key?" [custom_special_forms; name])) then (make_cek_value ((cek_call ((get (custom_special_forms) (name))) (List [args; env]))) (env) (kont)) else (if sx_truthy ((let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_macro ((env_get (env) (name)))))) then (let mac = (env_get (env) (name)) in (make_cek_state ((expand_macro (mac) (args) (env))) (env) (kont))) else (if sx_truthy ((let _and = render_check in if not (sx_truthy _and) then _and else (cek_call (render_check) (List [expr; env])))) then (make_cek_value ((cek_call (render_fn) (List [expr; env]))) (env) (kont)) else (step_eval_call (head) (args) (env) (kont)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) else (step_eval_call (head) (args) (env) (kont))))) + (let head = (first (expr)) in let args = (rest (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((let _or = (prim_call "=" [(type_of (head)); (String "symbol")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [(type_of (head)); (String "lambda")]) in if sx_truthy _or then _or else (prim_call "=" [(type_of (head)); (String "list")])))))))) then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (make_cek_state ((first (expr))) (env) ((kont_push ((make_map_frame (Nil) ((rest (expr))) ((List [])) (env))) (kont))))) else (if sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])) then (let name = (symbol_name (head)) in (let _match_val = name in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (step_sf_if (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (step_sf_when (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (step_sf_cond (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (step_sf_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (step_sf_and (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (step_sf_or (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "let*")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "lambda")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "fn")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defcomp")])) then (make_cek_value ((sf_defcomp (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defisland")])) then (make_cek_value ((sf_defisland (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defmacro")])) then (make_cek_value ((sf_defmacro (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "defio")])) then (make_cek_value ((sf_defio (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "io")])) then (step_sf_io (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "do")])) then (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (args)))))) in if not (sx_truthy _and) then _and else (let _and = (list_p ((first (args)))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p ((first (args)))))))) in if not (sx_truthy _and) then _and else (list_p ((first ((first (args)))))))))) then (let bindings = (first (args)) in let test_clause = (nth (args) ((Number 1.0))) in let body = (rest ((rest (args)))) in let vars = (List (List.map (fun b -> (first (b))) (sx_to_list bindings))) in let inits = (List (List.map (fun b -> (nth (b) ((Number 1.0)))) (sx_to_list bindings))) in let steps = (List (List.map (fun b -> (if sx_truthy ((prim_call ">" [(len (b)); (Number 2.0)])) then (nth (b) ((Number 2.0))) else (first (b)))) (sx_to_list bindings))) in let test = (first (test_clause)) in let result' = (rest (test_clause)) in (step_eval_list ((cons ((Symbol "let")) ((cons ((Symbol "__do-loop")) ((cons ((List (List.map (fun b -> (List [(first (b)); (nth (b) ((Number 1.0)))])) (sx_to_list bindings)))) ((List [(cons ((Symbol "if")) ((cons (test) ((cons ((if sx_truthy ((empty_p (result'))) then Nil else (cons ((Symbol "begin")) (result')))) ((List [(cons ((Symbol "begin")) ((prim_call "append" [body; (List [(cons ((Symbol "__do-loop")) (steps))])])))])))))))])))))))) (env) (kont))) else (step_sf_begin (args) (env) (kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "guard")])) then (step_sf_guard (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "quote")])) then (make_cek_value ((if sx_truthy ((empty_p (args))) then Nil else (first (args)))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "quasiquote")])) then (make_cek_value ((qq_expand ((first (args))) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "->")])) then (step_sf_thread_first (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "->>")])) then (step_sf_thread_last (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "|>")])) then (step_sf_thread_last (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "as->")])) then (step_sf_thread_as (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "set!")])) then (step_sf_set_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "letrec")])) then (step_sf_letrec (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (step_sf_reset (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "shift")])) then (step_sf_shift (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (step_sf_deref (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (step_sf_scope (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (step_sf_provide (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler-bind")])) then (step_sf_handler_bind (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart-case")])) then (step_sf_restart_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-condition")])) then (step_sf_signal (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "invoke-restart")])) then (step_sf_invoke_restart (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "match")])) then (step_sf_match (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "dynamic-wind")])) then (make_cek_value ((sf_dynamic_wind (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (step_ho_map (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (step_ho_map_indexed (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (step_ho_filter (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (step_ho_reduce (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (step_ho_some (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "every?")])) then (step_ho_every (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (step_ho_for_each (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise")])) then (step_sf_raise (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-continuable")])) then (make_cek_state ((first (args))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool true)))) (kont)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "call/cc")])) then (step_sf_callcc (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "call-with-current-continuation")])) then (step_sf_callcc (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (step_sf_perform (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-library")])) then (step_sf_define_library (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (step_sf_import (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-record-type")])) then (make_cek_value ((sf_define_record_type (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "parameterize")])) then (step_sf_parameterize (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "syntax-rules")])) then (make_cek_value ((sf_syntax_rules (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "define-syntax")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((prim_call "has-key?" [custom_special_forms; name])) then (make_cek_value ((cek_call ((get (custom_special_forms) (name))) (List [args; env]))) (env) (kont)) else (if sx_truthy ((let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_macro ((env_get (env) (name)))))) then (let mac = (env_get (env) (name)) in (make_cek_state ((expand_macro (mac) (args) (env))) (env) (kont))) else (if sx_truthy ((let _and = render_check in if not (sx_truthy _and) then _and else (cek_call (render_check) (List [expr; env])))) then (make_cek_value ((cek_call (render_fn) (List [expr; env]))) (env) (kont)) else (step_eval_call (head) (args) (env) (kont)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) else (step_eval_call (head) (args) (env) (kont))))) + +(* step-sf-parameterize *) +and step_sf_parameterize args env kont = + (let bindings = (first (args)) in let body = (rest (args)) in (if sx_truthy ((let _or = (is_nil (bindings)) in if sx_truthy _or then _or else (empty_p (bindings)))) then (step_sf_begin (body) (env) (kont)) else (let first_pair = (first (bindings)) in (make_cek_state ((first (first_pair))) (env) ((kont_push ((make_parameterize_frame (bindings) (Nil) ((List [])) (body) (env))) (kont))))))) + +(* syntax-rules-match *) +and syntax_rules_match pattern form literals = + (if sx_truthy ((let _and = (symbol_p (pattern)) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (pattern)); (String "_")]))) then (Dict (Hashtbl.create 0)) else (if sx_truthy ((let _and = (symbol_p (pattern)) in if not (sx_truthy _and) then _and else (prim_call "contains?" [literals; (symbol_name (pattern))]))) then (if sx_truthy ((let _and = (symbol_p (form)) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (pattern)); (symbol_name (form))]))) then (Dict (Hashtbl.create 0)) else Nil) else (if sx_truthy ((symbol_p (pattern))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((sx_dict_set_b d (symbol_name (pattern)) form)) in d)) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (empty_p (pattern)))) then (if sx_truthy ((let _and = (list_p (form)) in if not (sx_truthy _and) then _and else (empty_p (form)))) then (Dict (Hashtbl.create 0)) else Nil) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (list_p (form)))) then (syntax_rules_match_list (pattern) ((Number 0.0)) (form) ((Number 0.0)) (literals)) else (if sx_truthy ((prim_call "=" [pattern; form])) then (Dict (Hashtbl.create 0)) else Nil)))))) + +(* syntax-rules-match-list *) +and syntax_rules_match_list pattern pi form fi literals = + (let plen = (len (pattern)) in let flen = (len (form)) in (if sx_truthy ((let _and = (prim_call ">=" [pi; plen]) in if not (sx_truthy _and) then _and else (prim_call ">=" [fi; flen]))) then (Dict (Hashtbl.create 0)) else (if sx_truthy ((prim_call ">=" [pi; plen])) then Nil else (if sx_truthy ((let _and = (prim_call "<" [(prim_call "+" [pi; (Number 1.0)]); plen]) in if not (sx_truthy _and) then _and else (let _and = (symbol_p ((nth (pattern) ((prim_call "+" [pi; (Number 1.0)]))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (pattern) ((prim_call "+" [pi; (Number 1.0)]))))); (String "...")])))) then (let sub_pat = (nth (pattern) (pi)) in let rest_pat_count = (prim_call "-" [plen; (prim_call "+" [pi; (Number 2.0)])]) in let available = (prim_call "-" [flen; fi]) in let n_ellipsis = (prim_call "-" [(prim_call "-" [flen; fi]); (prim_call "-" [plen; (prim_call "+" [pi; (Number 2.0)])])]) in (if sx_truthy ((prim_call "<" [n_ellipsis; (Number 0.0)])) then Nil else (let ellipsis_forms = (prim_call "slice" [form; fi; (prim_call "+" [fi; n_ellipsis])]) in let sub_bindings = (List (List.map (fun f -> (syntax_rules_match (sub_pat) (f) (literals))) (sx_to_list (prim_call "slice" [form; fi; (prim_call "+" [fi; n_ellipsis])])))) in (if sx_truthy ((prim_call "contains?" [sub_bindings; Nil])) then Nil else (let rest_result = (syntax_rules_match_list (pattern) ((prim_call "+" [pi; (Number 2.0)])) (form) ((prim_call "+" [fi; n_ellipsis])) (literals)) in (if sx_truthy ((is_nil (rest_result))) then Nil else (let merged = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun b -> ignore ((List.iter (fun key -> ignore ((let existing = (dict_get (merged) (key)) in (if sx_truthy ((is_nil (existing))) then (sx_dict_set_b merged key (List [(get (b) (key))])) else (sx_dict_set_b merged key (prim_call "append" [existing; (List [(get (b) (key))])])))))) (sx_to_list (prim_call "keys" [b])); Nil))) (sx_to_list sub_bindings); Nil)) in (let () = ignore ((List.iter (fun key -> ignore ((sx_dict_set_b merged key (get (rest_result) (key))))) (sx_to_list (prim_call "keys" [rest_result])); Nil)) in merged))))))))) else (if sx_truthy ((prim_call ">=" [fi; flen])) then Nil else (let sub_result = (syntax_rules_match ((nth (pattern) (pi))) ((nth (form) (fi))) (literals)) in (if sx_truthy ((is_nil (sub_result))) then Nil else (let rest_result = (syntax_rules_match_list (pattern) ((prim_call "+" [pi; (Number 1.0)])) (form) ((prim_call "+" [fi; (Number 1.0)])) (literals)) in (if sx_truthy ((is_nil (rest_result))) then Nil else (let () = ignore ((List.iter (fun key -> ignore ((sx_dict_set_b rest_result key (get (sub_result) (key))))) (sx_to_list (prim_call "keys" [sub_result])); Nil)) in rest_result)))))))))) + +(* syntax-rules-find-var *) +and syntax_rules_find_var template bindings = + (if sx_truthy ((let _and = (symbol_p (template)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "has-key?" [bindings; (symbol_name (template))]) in if not (sx_truthy _and) then _and else (list_p ((get (bindings) ((symbol_name (template))))))))) then (symbol_name (template)) else (if sx_truthy ((list_p (template))) then (List.fold_left (fun found t -> (if sx_truthy ((is_nil (found))) then (syntax_rules_find_var (t) (bindings)) else found)) Nil (sx_to_list template)) else Nil)) + +(* syntax-rules-find-all-vars *) +and syntax_rules_find_all_vars template bindings = + (if sx_truthy ((let _and = (symbol_p (template)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "has-key?" [bindings; (symbol_name (template))]) in if not (sx_truthy _and) then _and else (list_p ((get (bindings) ((symbol_name (template))))))))) then (List [(symbol_name (template))]) else (if sx_truthy ((list_p (template))) then (List.fold_left (fun acc t -> (prim_call "append" [acc; (syntax_rules_find_all_vars (t) (bindings))])) (List []) (sx_to_list template)) else (List []))) + +(* syntax-rules-instantiate *) +and syntax_rules_instantiate template bindings = + (if sx_truthy ((let _and = (symbol_p (template)) in if not (sx_truthy _and) then _and else (prim_call "has-key?" [bindings; (symbol_name (template))]))) then (get (bindings) ((symbol_name (template)))) else (if sx_truthy ((Bool (not (sx_truthy ((list_p (template))))))) then template else (if sx_truthy ((empty_p (template))) then template else (syntax_rules_instantiate_list (template) ((Number 0.0)) (bindings))))) + +(* syntax-rules-instantiate-list *) +and syntax_rules_instantiate_list template i bindings = + (if sx_truthy ((prim_call ">=" [i; (len (template))])) then (List []) else (let elem = (nth (template) (i)) in let has_ellipsis = (let _and = (prim_call "<" [(prim_call "+" [i; (Number 1.0)]); (len (template))]) in if not (sx_truthy _and) then _and else (let _and = (symbol_p ((nth (template) ((prim_call "+" [i; (Number 1.0)]))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (template) ((prim_call "+" [i; (Number 1.0)]))))); (String "...")]))) in (if sx_truthy (has_ellipsis) then (let all_vars = (syntax_rules_find_all_vars (elem) (bindings)) in (if sx_truthy ((empty_p (all_vars))) then (syntax_rules_instantiate_list (template) ((prim_call "+" [i; (Number 2.0)])) (bindings)) else (let count = (len ((get (bindings) ((first (all_vars)))))) in let expanded = (List (List.map (fun idx -> (let b = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun key -> ignore ((sx_dict_set_b b key (get (bindings) (key))))) (sx_to_list (prim_call "keys" [bindings])); Nil)) in (let () = ignore ((List.iter (fun var_name -> ignore ((sx_dict_set_b b var_name (nth ((get (bindings) (var_name))) (idx))))) (sx_to_list all_vars); Nil)) in (syntax_rules_instantiate (elem) (b)))))) (sx_to_list (prim_call "range" [count])))) in let rest_result = (syntax_rules_instantiate_list (template) ((prim_call "+" [i; (Number 2.0)])) (bindings)) in (prim_call "append" [expanded; rest_result])))) else (cons ((syntax_rules_instantiate (elem) (bindings))) ((syntax_rules_instantiate_list (template) ((prim_call "+" [i; (Number 1.0)])) (bindings))))))) + +(* syntax-rules-expand *) +and syntax_rules_expand literals rules form = + (let full_form = (cons ((make_symbol ((String "_")))) (form)) in (syntax_rules_try_rules (literals) (rules) (full_form))) + +(* syntax-rules-try-rules *) +and syntax_rules_try_rules literals rules full_form = + (if sx_truthy ((empty_p (rules))) then (raise (Eval_error (value_to_str (String (sx_str [(String "syntax-rules: no pattern matched for "); (inspect (full_form))]))))) else (let rule = (first (rules)) in let pattern = (first (rule)) in let template = (nth (rule) ((Number 1.0))) in (let bindings = (syntax_rules_match (pattern) (full_form) (literals)) in (if sx_truthy ((Bool (not (sx_truthy ((is_nil (bindings))))))) then (syntax_rules_instantiate (template) (bindings)) else (syntax_rules_try_rules (literals) ((rest (rules))) (full_form)))))) + +(* sf-syntax-rules *) +and sf_syntax_rules args env = + (let literals = (if sx_truthy ((list_p ((first (args))))) then (List (List.map (fun s -> (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s])))) (sx_to_list (first (args))))) else (List [])) in let rules = (rest (args)) in (let closure = (env_extend (env)) in (let () = ignore ((env_bind closure (sx_to_string (String "__sr-literals")) literals)) in (let () = ignore ((env_bind closure (sx_to_string (String "__sr-rules")) rules)) in (make_macro ((List [])) ((String "__sr-form")) ((Symbol "__syntax-rules-body__")) (closure) ((String "syntax-rules"))))))) (* step-sf-define-library *) and step_sf_define_library args env kont = @@ -589,13 +645,17 @@ and step_sf_or args env kont = and step_sf_cond args env kont = (let scheme_p = (cond_scheme_p (args)) in (if sx_truthy (scheme_p) then (if sx_truthy ((empty_p (args))) then (make_cek_value (Nil) (env) (kont)) else (let clause = (first (args)) in let test = (first (clause)) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state ((nth (clause) ((Number 1.0)))) (env) (kont)) else (make_cek_state (test) (env) ((kont_push ((make_cond_frame (args) (env) ((Bool true)))) (kont))))))) else (if sx_truthy ((prim_call "<" [(len (args)); (Number 2.0)])) then (make_cek_value (Nil) (env) (kont)) else (let test = (first (args)) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state ((nth (args) ((Number 1.0)))) (env) (kont)) else (make_cek_state (test) (env) ((kont_push ((make_cond_frame (args) (env) ((Bool false)))) (kont))))))))) -(* step-sf-case *) -and step_sf_case args env kont = - (make_cek_state ((first (args))) (env) ((kont_push ((make_case_frame (Nil) ((rest (args))) (env))) (kont)))) - (* step-sf-thread-first *) and step_sf_thread_first args env kont = - (make_cek_state ((first (args))) (env) ((kont_push ((make_thread_frame ((rest (args))) (env))) (kont)))) + (make_cek_state ((first (args))) (env) ((kont_push ((make_thread_frame ((rest (args))) (env) ((String "first")) (Nil))) (kont)))) + +(* step-sf-thread-last *) +and step_sf_thread_last args env kont = + (make_cek_state ((first (args))) (env) ((kont_push ((make_thread_frame ((rest (args))) (env) ((String "last")) (Nil))) (kont)))) + +(* step-sf-thread-as *) +and step_sf_thread_as args env kont = + (let init = (first (args)) in let name = (nth (args) ((Number 1.0))) in let forms = (rest ((rest (args)))) in (make_cek_state (init) (env) ((kont_push ((make_thread_frame (forms) (env) ((String "as")) (name))) (kont))))) (* step-sf-lambda *) and step_sf_lambda args env kont = @@ -691,11 +751,11 @@ and step_ho_for_each args env kont = (* step-continue *) and step_continue state = - let _last_error_kont_ = ref Nil in (let value = (cek_value (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (if sx_truthy ((kont_empty_p (kont))) then state else (let frame = (kont_top (kont)) in let rest_k = (kont_pop (kont)) in let ft = (frame_type (frame)) in (let _match_val = ft in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (make_cek_state ((get (frame) ((String "then")))) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((is_nil ((get (frame) ((String "else")))))) then (make_cek_value (Nil) (env) (rest_k)) else (make_cek_state ((get (frame) ((String "else")))) ((get (frame) ((String "env")))) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (make_cek_state ((first (body))) (fenv) (rest_k)) else (make_cek_state ((first (body))) (fenv) ((kont_push ((make_begin_frame ((rest (body))) (fenv))) (rest_k))))))) else (make_cek_value (Nil) (env) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then (make_cek_state ((first (remaining))) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_begin_frame ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let body = (get (frame) ((String "body"))) in let local = (get (frame) ((String "env"))) in (let () = ignore ((env_bind local (sx_to_string name) value)) in (if sx_truthy ((empty_p (remaining))) then (step_sf_begin (body) (local) (rest_k)) else (let next_binding = (first (remaining)) in let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (next_binding)))); (String "symbol")])) then (symbol_name ((first (next_binding)))) else (first (next_binding))) in (make_cek_state ((nth (next_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) ((rest (remaining))) (body) (local))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let has_effects = (get (frame) ((String "has-effects"))) in let effect_list = (get (frame) ((String "effect-list"))) in (let () = ignore ((if sx_truthy ((let _and = (is_lambda (value)) in if not (sx_truthy _and) then _and else (is_nil ((lambda_name (value)))))) then (set_lambda_name value (sx_to_string name)) else Nil)) in (let () = ignore ((env_bind fenv (sx_to_string name) value)) in (let () = ignore ((if sx_truthy (has_effects) then (let effect_names = (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else e)) (sx_to_list effect_list))) in let effect_anns = (if sx_truthy ((env_has (fenv) ((String "*effect-annotations*")))) then (env_get (fenv) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns name effect_names)) in (env_bind fenv (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (make_cek_value (value) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((env_set fenv (sx_to_string name) value)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_and_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (if sx_truthy (value) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_or_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let scheme_p = (get (frame) ((String "scheme"))) in (if sx_truthy (scheme_p) then (if sx_truthy (value) then (let clause = (first (remaining)) in (if sx_truthy ((let _and = (prim_call ">" [(len (clause)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (clause) ((Number 1.0))))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (clause) ((Number 1.0))))); (String "=>")])))) then (make_cek_state ((nth (clause) ((Number 2.0)))) (fenv) ((kont_push ((make_cond_arrow_frame (value) (fenv))) (rest_k)))) else (make_cek_state ((nth (clause) ((Number 1.0)))) (fenv) (rest_k)))) else (let next_clauses = (rest (remaining)) in (if sx_truthy ((empty_p (next_clauses))) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_clause = (first (next_clauses)) in let next_test = (first (next_clause)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next_clause) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next_clauses) (fenv) ((Bool true)))) (rest_k))))))))) else (if sx_truthy (value) then (make_cek_state ((nth (remaining) ((Number 1.0)))) (fenv) (rest_k)) else (let next = (prim_call "slice" [remaining; (Number 2.0); (len (remaining))]) in (if sx_truthy ((prim_call "<" [(len (next)); (Number 2.0)])) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_test = (first (next)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next) (fenv) ((Bool false)))) (rest_k))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (let match_val = (get (frame) ((String "match-val"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (match_val))) then (sf_case_step_loop (value) (remaining) (fenv) (rest_k)) else (sf_case_step_loop (match_val) (remaining) (fenv) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "thread")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (let form = (first (remaining)) in let rest_forms = (rest (remaining)) in let new_kont = (if sx_truthy ((empty_p ((rest (remaining))))) then rest_k else (kont_push ((make_thread_frame ((rest (remaining))) (fenv))) (rest_k))) in (if sx_truthy ((let _and = (prim_call "=" [(type_of (form)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (form)))))) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (form)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (ho_form_name_p ((symbol_name ((first (form)))))))))) then (make_cek_state ((cons ((first (form))) ((cons ((List [(Symbol "quote"); value])) ((rest (form))))))) (fenv) (new_kont)) else (let result' = (thread_insert_arg (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv))) (rest_k)))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "arg")])) then (let f = (get (frame) ((String "f"))) in let evaled = (get (frame) ((String "evaled"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let raw_args = (get (frame) ((String "raw-args"))) in let hname = (get (frame) ((String "head-name"))) in (if sx_truthy ((is_nil (f))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) ((List []))) else Nil)) in (if sx_truthy ((empty_p (remaining))) then (continue_with_call (value) ((List [])) (fenv) (raw_args) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (value) ((List [])) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))) else (let new_evaled = (prim_call "append" [evaled; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) (new_evaled)) else Nil)) in (continue_with_call (f) (new_evaled) (fenv) (raw_args) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (f) (new_evaled) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "dict")])) then (let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let fenv = (get (frame) ((String "env"))) in (let last_result = (last (results)) in let completed = (prim_call "append" [(prim_call "slice" [results; (Number 0.0); (prim_call "dec" [(len (results))])]); (List [(List [(first (last_result)); value])])]) in (if sx_truthy ((empty_p (remaining))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun pair -> ignore ((sx_dict_set_b d (first (pair)) (nth (pair) ((Number 1.0)))))) (sx_to_list completed); Nil)) in (make_cek_value (d) (fenv) (rest_k)))) else (let next_entry = (first (remaining)) in (make_cek_state ((nth (next_entry) ((Number 1.0)))) (fenv) ((kont_push ((make_dict_frame ((rest (remaining))) ((prim_call "append" [completed; (List [(List [(first (next_entry))])])])) (fenv))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "ho-setup")])) then (let ho_type = (get (frame) ((String "ho-type"))) in let remaining = (get (frame) ((String "remaining"))) in let evaled = (prim_call "append" [(get (frame) ((String "evaled"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (ho_setup_dispatch (ho_type) (evaled) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_ho_setup_frame (ho_type) ((rest (remaining))) (evaled) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (let val' = value in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy ((is_signal (val'))))))) then (make_cek_value (val') (fenv) (rest_k)) else (if sx_truthy ((has_reactive_reset_frame_p (rest_k))) then (reactive_shift_deref (val') (fenv) (rest_k)) else (let () = ignore ((let ctx = (sx_context ((String "sx-reactive")) (Nil)) in (if sx_truthy (ctx) then (let dep_list = ref ((get (ctx) ((String "deps")))) in let notify_fn = (get (ctx) ((String "notify"))) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!dep_list; val'])))))) then (let () = ignore ((dep_list := sx_append_b !dep_list val'; Nil)) in (signal_add_sub_b (val') (notify_fn))) else Nil)) else Nil))) in (make_cek_value ((signal_value (val'))) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reactive-reset")])) then (let update_fn = (get (frame) ((String "update-fn"))) in let first_p = (get (frame) ((String "first-render"))) in (let () = ignore ((if sx_truthy ((let _and = update_fn in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (first_p)))))) then (cek_call (update_fn) ((List [value]))) else Nil)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop (name))) in (make_cek_value (value) (fenv) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_scope_frame (name) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope-acc")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((let new_frame = (make_scope_acc_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "emitted") (get (frame) ((String "emitted"))))) in new_frame))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let indexed = (get (frame) ((String "indexed"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (prim_call "append" [results; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let call_args = (if sx_truthy (indexed) then (List [(len (new_results)); (first (remaining))]) else (List [(first (remaining))])) in let next_frame = (if sx_truthy (indexed) then (make_map_indexed_frame (f) ((rest (remaining))) (new_results) (fenv)) else (make_map_frame (f) ((rest (remaining))) (new_results) (fenv))) in (continue_with_call (f) (call_args) (fenv) ((List [])) ((kont_push (next_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let current_item = (get (frame) ((String "current-item"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (if sx_truthy (value) then (prim_call "append" [results; (List [current_item])]) else results) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (remaining))) (new_results) ((first (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (continue_with_call (f) ((List [value; (first (remaining))])) (fenv) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (Nil) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy (value) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_some_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool true)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_every_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_handler_frame ((get (frame) ((String "f")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-return")])) then (let saved_kont = (get (frame) ((String "saved-kont"))) in (make_cek_value (value) ((get (frame) ((String "env")))) (saved_kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "comp-trace")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond-arrow")])) then (let test_value = (get (frame) ((String "match-val"))) in let fenv = (get (frame) ((String "env"))) in (continue_with_call (value) ((List [test_value])) (fenv) ((List [test_value])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-eval")])) then (let condition = value in let fenv = (get (frame) ((String "env"))) in let continuable_p = (get (frame) ((String "scheme"))) in let handler_fn = (kont_find_handler (rest_k) (condition)) in (if sx_truthy ((is_nil (handler_fn))) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String (sx_str [(String "Unhandled exception: "); (inspect (condition))]))))) else (continue_with_call (handler_fn) ((List [condition])) (fenv) ((List [condition])) ((if sx_truthy (continuable_p) then (kont_push ((make_signal_return_frame (fenv) (rest_k))) (rest_k)) else (kont_push ((make_raise_guard_frame (fenv) (rest_k))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-guard")])) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String "exception handler returned from non-continuable raise")))) else (if sx_truthy ((prim_call "=" [_match_val; (String "multi-map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let new_results = (prim_call "append" [(get (frame) ((String "results"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list remaining)))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list remaining))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list remaining))) in (continue_with_call (f) (heads) (fenv) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) (new_results) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "callcc")])) then (let k = (make_callcc_continuation (rest_k)) in (continue_with_call (value) ((List [k])) ((get (frame) ((String "env")))) ((List [k])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "vm-resume")])) then (let resume_fn = (get (frame) ((String "f"))) in (let result' = (sx_apply resume_fn (List [value])) in (if sx_truthy ((let _and = (dict_p (result')) in if not (sx_truthy _and) then _and else (get (result') ((String "__vm_suspended"))))) then (make_cek_suspended ((get (result') ((String "request")))) ((get (frame) ((String "env")))) ((kont_push ((make_vm_resume_frame ((get (result') ((String "resume")))) ((get (frame) ((String "env")))))) (rest_k)))) else (make_cek_value (result') ((get (frame) ((String "env")))) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (make_cek_suspended (value) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (let import_set = (get (frame) ((String "args"))) in let remaining_sets = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((bind_import_set (import_set) (fenv))) in (if sx_truthy ((empty_p (remaining_sets))) then (make_cek_value (Nil) (fenv) (rest_k)) else (step_sf_import (remaining_sets) (fenv) (rest_k))))) else (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown frame type: "); ft])))))))))))))))))))))))))))))))))))))))))))))))) + let _last_error_kont_ = ref Nil in (let value = (cek_value (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (if sx_truthy ((kont_empty_p (kont))) then state else (let frame = (kont_top (kont)) in let rest_k = (kont_pop (kont)) in let ft = (frame_type (frame)) in (let _match_val = ft in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (make_cek_state ((get (frame) ((String "then")))) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((is_nil ((get (frame) ((String "else")))))) then (make_cek_value (Nil) (env) (rest_k)) else (make_cek_state ((get (frame) ((String "else")))) ((get (frame) ((String "env")))) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (make_cek_state ((first (body))) (fenv) (rest_k)) else (make_cek_state ((first (body))) (fenv) ((kont_push ((make_begin_frame ((rest (body))) (fenv))) (rest_k))))))) else (make_cek_value (Nil) (env) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then (make_cek_state ((first (remaining))) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_begin_frame ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let body = (get (frame) ((String "body"))) in let local = (get (frame) ((String "env"))) in (let () = ignore ((env_bind local (sx_to_string name) value)) in (if sx_truthy ((empty_p (remaining))) then (step_sf_begin (body) (local) (rest_k)) else (let next_binding = (first (remaining)) in let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (next_binding)))); (String "symbol")])) then (symbol_name ((first (next_binding)))) else (first (next_binding))) in (make_cek_state ((nth (next_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) ((rest (remaining))) (body) (local))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let has_effects = (get (frame) ((String "has-effects"))) in let effect_list = (get (frame) ((String "effect-list"))) in (let () = ignore ((if sx_truthy ((let _and = (is_lambda (value)) in if not (sx_truthy _and) then _and else (is_nil ((lambda_name (value)))))) then (set_lambda_name value (sx_to_string name)) else Nil)) in (let () = ignore ((env_bind fenv (sx_to_string name) value)) in (let () = ignore ((if sx_truthy (has_effects) then (let effect_names = (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else e)) (sx_to_list effect_list))) in let effect_anns = (if sx_truthy ((env_has (fenv) ((String "*effect-annotations*")))) then (env_get (fenv) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns name effect_names)) in (env_bind fenv (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (make_cek_value (value) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((env_set fenv (sx_to_string name) value)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_and_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (if sx_truthy (value) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_or_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let scheme_p = (get (frame) ((String "scheme"))) in (if sx_truthy (scheme_p) then (if sx_truthy (value) then (let clause = (first (remaining)) in (if sx_truthy ((let _and = (prim_call ">" [(len (clause)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (clause) ((Number 1.0))))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (clause) ((Number 1.0))))); (String "=>")])))) then (make_cek_state ((nth (clause) ((Number 2.0)))) (fenv) ((kont_push ((make_cond_arrow_frame (value) (fenv))) (rest_k)))) else (make_cek_state ((nth (clause) ((Number 1.0)))) (fenv) (rest_k)))) else (let next_clauses = (rest (remaining)) in (if sx_truthy ((empty_p (next_clauses))) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_clause = (first (next_clauses)) in let next_test = (first (next_clause)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next_clause) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next_clauses) (fenv) ((Bool true)))) (rest_k))))))))) else (if sx_truthy (value) then (make_cek_state ((nth (remaining) ((Number 1.0)))) (fenv) (rest_k)) else (let next = (prim_call "slice" [remaining; (Number 2.0); (len (remaining))]) in (if sx_truthy ((prim_call "<" [(len (next)); (Number 2.0)])) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_test = (first (next)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next) (fenv) ((Bool false)))) (rest_k))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (let match_val = (get (frame) ((String "match-val"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (match_val))) then (sf_case_step_loop (value) (remaining) (fenv) (rest_k)) else (sf_case_step_loop (match_val) (remaining) (fenv) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "thread")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let mode = (get (frame) ((String "extra"))) in let bind_name = (get (frame) ((String "name"))) 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) (mode) (bind_name))) (rest_k))) in (if sx_truthy ((prim_call "=" [mode; (String "as")])) then (let new_env = (env_extend (fenv)) in (let () = ignore ((env_bind new_env (sx_to_string (symbol_name (bind_name))) value)) in (make_cek_state (form) (new_env) (new_kont)))) else (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 (if sx_truthy ((prim_call "=" [mode; (String "last")])) then (let result' = (thread_insert_arg_last (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv) (mode) (bind_name))) (rest_k)))))) else (let result' = (thread_insert_arg (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv) (mode) (bind_name))) (rest_k)))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "arg")])) then (let f = (get (frame) ((String "f"))) in let evaled = (get (frame) ((String "evaled"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let raw_args = (get (frame) ((String "raw-args"))) in let hname = (get (frame) ((String "head-name"))) in (if sx_truthy ((is_nil (f))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) ((List []))) else Nil)) in (if sx_truthy ((empty_p (remaining))) then (continue_with_call (value) ((List [])) (fenv) (raw_args) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (value) ((List [])) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))) else (let new_evaled = (prim_call "append" [evaled; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) (new_evaled)) else Nil)) in (continue_with_call (f) (new_evaled) (fenv) (raw_args) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (f) (new_evaled) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "dict")])) then (let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let fenv = (get (frame) ((String "env"))) in (let last_result = (last (results)) in let completed = (prim_call "append" [(prim_call "slice" [results; (Number 0.0); (prim_call "dec" [(len (results))])]); (List [(List [(first (last_result)); value])])]) in (if sx_truthy ((empty_p (remaining))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun pair -> ignore ((sx_dict_set_b d (first (pair)) (nth (pair) ((Number 1.0)))))) (sx_to_list completed); Nil)) in (make_cek_value (d) (fenv) (rest_k)))) else (let next_entry = (first (remaining)) in (make_cek_state ((nth (next_entry) ((Number 1.0)))) (fenv) ((kont_push ((make_dict_frame ((rest (remaining))) ((prim_call "append" [completed; (List [(List [(first (next_entry))])])])) (fenv))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "ho-setup")])) then (let ho_type = (get (frame) ((String "ho-type"))) in let remaining = (get (frame) ((String "remaining"))) in let evaled = (prim_call "append" [(get (frame) ((String "evaled"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (ho_setup_dispatch (ho_type) (evaled) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_ho_setup_frame (ho_type) ((rest (remaining))) (evaled) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (let val' = value in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy ((is_signal (val'))))))) then (make_cek_value (val') (fenv) (rest_k)) else (if sx_truthy ((has_reactive_reset_frame_p (rest_k))) then (reactive_shift_deref (val') (fenv) (rest_k)) else (let () = ignore ((let ctx = (sx_context ((String "sx-reactive")) (Nil)) in (if sx_truthy (ctx) then (let dep_list = ref ((get (ctx) ((String "deps")))) in let notify_fn = (get (ctx) ((String "notify"))) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!dep_list; val'])))))) then (let () = ignore ((dep_list := sx_append_b !dep_list val'; Nil)) in (signal_add_sub_b (val') (notify_fn))) else Nil)) else Nil))) in (make_cek_value ((signal_value (val'))) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reactive-reset")])) then (let update_fn = (get (frame) ((String "update-fn"))) in let first_p = (get (frame) ((String "first-render"))) in (let () = ignore ((if sx_truthy ((let _and = update_fn in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (first_p)))))) then (cek_call (update_fn) ((List [value]))) else Nil)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop (name))) in (make_cek_value (value) (fenv) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_scope_frame (name) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope-acc")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((let new_frame = (make_scope_acc_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "emitted") (get (frame) ((String "emitted"))))) in new_frame))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let indexed = (get (frame) ((String "indexed"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (prim_call "append" [results; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let call_args = (if sx_truthy (indexed) then (List [(len (new_results)); (first (remaining))]) else (List [(first (remaining))])) in let next_frame = (if sx_truthy (indexed) then (make_map_indexed_frame (f) ((rest (remaining))) (new_results) (fenv)) else (make_map_frame (f) ((rest (remaining))) (new_results) (fenv))) in (continue_with_call (f) (call_args) (fenv) ((List [])) ((kont_push (next_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let current_item = (get (frame) ((String "current-item"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (if sx_truthy (value) then (prim_call "append" [results; (List [current_item])]) else results) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (remaining))) (new_results) ((first (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (continue_with_call (f) ((List [value; (first (remaining))])) (fenv) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (Nil) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy (value) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_some_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool true)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_every_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_handler_frame ((get (frame) ((String "f")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-return")])) then (let saved_kont = (get (frame) ((String "saved-kont"))) in (make_cek_value (value) ((get (frame) ((String "env")))) (saved_kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "comp-trace")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond-arrow")])) then (let test_value = (get (frame) ((String "match-val"))) in let fenv = (get (frame) ((String "env"))) in (continue_with_call (value) ((List [test_value])) (fenv) ((List [test_value])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-eval")])) then (let condition = value in let fenv = (get (frame) ((String "env"))) in let continuable_p = (get (frame) ((String "scheme"))) in let handler_fn = (kont_find_handler (rest_k) (condition)) in (if sx_truthy ((is_nil (handler_fn))) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String (sx_str [(String "Unhandled exception: "); (inspect (condition))]))))) else (continue_with_call (handler_fn) ((List [condition])) (fenv) ((List [condition])) ((if sx_truthy (continuable_p) then (kont_push ((make_signal_return_frame (fenv) (rest_k))) (rest_k)) else (kont_push ((make_raise_guard_frame (fenv) (rest_k))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-guard")])) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String "exception handler returned from non-continuable raise")))) else (if sx_truthy ((prim_call "=" [_match_val; (String "multi-map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let new_results = (prim_call "append" [(get (frame) ((String "results"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list remaining)))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list remaining))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list remaining))) in (continue_with_call (f) (heads) (fenv) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) (new_results) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "callcc")])) then (let k = (make_callcc_continuation (rest_k)) in (continue_with_call (value) ((List [k])) ((get (frame) ((String "env")))) ((List [k])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "vm-resume")])) then (let resume_fn = (get (frame) ((String "f"))) in (let result' = (sx_apply resume_fn (List [value])) in (if sx_truthy ((let _and = (dict_p (result')) in if not (sx_truthy _and) then _and else (get (result') ((String "__vm_suspended"))))) then (make_cek_suspended ((get (result') ((String "request")))) ((get (frame) ((String "env")))) ((kont_push ((make_vm_resume_frame ((get (result') ((String "resume")))) ((get (frame) ((String "env")))))) (rest_k)))) else (make_cek_value (result') ((get (frame) ((String "env")))) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (make_cek_suspended (value) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (let import_set = (get (frame) ((String "args"))) in let remaining_sets = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((bind_import_set (import_set) (fenv))) in (if sx_truthy ((empty_p (remaining_sets))) then (make_cek_value (Nil) (fenv) (rest_k)) else (step_sf_import (remaining_sets) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "parameterize")])) then (let remaining = (get (frame) ((String "remaining"))) in let current_param = (get (frame) ((String "f"))) in let results = (get (frame) ((String "results"))) in let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (current_param))) then (let param_obj = value in let val_expr = (nth ((first (remaining))) ((Number 1.0))) in (make_cek_state (val_expr) (fenv) ((kont_push ((make_parameterize_frame (remaining) (param_obj) (results) (body) (fenv))) (rest_k))))) else (let converted_val = value in let new_results = (prim_call "append" [results; (List [(List [(parameter_uid (current_param)); converted_val])])]) in let rest_bindings = (rest (remaining)) in (if sx_truthy ((empty_p (rest_bindings))) then (let body_expr = (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (first (body)) else (cons ((Symbol "begin")) (body))) in let provide_kont = (kont_push_provides (new_results) (fenv) (rest_k)) in (make_cek_state (body_expr) (fenv) (provide_kont))) else (make_cek_state ((first ((first (rest_bindings))))) (fenv) ((kont_push ((make_parameterize_frame (rest_bindings) (Nil) (new_results) (body) (fenv))) (rest_k)))))))) else (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown frame type: "); ft]))))))))))))))))))))))))))))))))))))))))))))))))) (* continue-with-call *) and continue_with_call f args env raw_args kont = - (if sx_truthy ((callcc_continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let captured = (callcc_continuation_data (f)) in (make_cek_value (arg) (env) (captured))) else (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (make_cek_value ((sx_apply f args)) (env) (kont)) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) 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" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (let jit_result = (jit_try_call (f) (args)) in (if sx_truthy ((is_nil (jit_result))) then (make_cek_state ((lambda_body (f))) (local) (kont)) else (if sx_truthy ((let _and = (dict_p (jit_result)) in if not (sx_truthy _and) then _and else (get (jit_result) ((String "__vm_suspended"))))) then (make_cek_suspended ((get (jit_result) ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (jit_result) ((String "resume")))) (env))) (kont)))) else (make_cek_value (jit_result) (local) (kont))))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_push ((make_comp_trace_frame ((component_name (f))) ((component_file (f))))) (kont))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))])))))))))) + (if sx_truthy ((parameter_p (f))) then (let uid = (parameter_uid (f)) in let frame = (kont_find_provide (kont) (uid)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (parameter_default (f)))) (env) (kont))) else (if sx_truthy ((callcc_continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let captured = (callcc_continuation_data (f)) in (make_cek_value (arg) (env) (captured))) else (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (make_cek_value ((sx_apply f args)) (env) (kont)) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) 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" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (let jit_result = (jit_try_call (f) (args)) in (if sx_truthy ((is_nil (jit_result))) then (make_cek_state ((lambda_body (f))) (local) (kont)) else (if sx_truthy ((let _and = (dict_p (jit_result)) in if not (sx_truthy _and) then _and else (get (jit_result) ((String "__vm_suspended"))))) then (make_cek_suspended ((get (jit_result) ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (jit_result) ((String "resume")))) (env))) (kont)))) else (make_cek_value (jit_result) (local) (kont))))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_push ((make_comp_trace_frame ((component_name (f))) ((component_file (f))))) (kont))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))]))))))))))) (* sf-case-step-loop *) and sf_case_step_loop match_val clauses env kont = diff --git a/spec/evaluator.sx b/spec/evaluator.sx index 9be97c8a..6c6bd753 100644 --- a/spec/evaluator.sx +++ b/spec/evaluator.sx @@ -64,7 +64,7 @@ ;; Higher-order iteration frames (define make-case-frame (fn (match-val remaining env) {:match-val match-val :env env :type "case" :remaining remaining})) -(define make-thread-frame (fn (remaining env) {:env env :type "thread" :remaining remaining})) +(define make-thread-frame (fn (remaining env mode name) {:env env :type "thread" :extra mode :remaining remaining :name name})) (define thread-insert-arg @@ -77,6 +77,15 @@ fenv) (eval-expr (list form (list (quote quote) value)) fenv)))) +(define + thread-insert-arg-last + (fn + (form value fenv) + (if + (= (type-of form) "list") + (eval-expr (append form (list (list (quote quote) value))) fenv) + (eval-expr (list form (list (quote quote) value)) fenv)))) + (define make-map-frame (fn (f remaining results env) {:indexed false :env env :results results :type "map" :f f :remaining remaining})) (define make-map-indexed-frame (fn (f remaining results env) {:indexed true :env env :results results :type "map" :f f :remaining remaining})) @@ -87,54 +96,55 @@ make-filter-frame (fn (f remaining results current-item env) {:current-item current-item :env env :results results :type "filter" :f f :remaining remaining})) +;; Scope/provide/context — downward data passing without env threading (define make-reduce-frame (fn (f remaining env) {:env env :type "reduce" :f f :remaining remaining})) -;; Scope/provide/context — downward data passing without env threading (define make-for-each-frame (fn (f remaining env) {:env env :type "for-each" :f f :remaining remaining})) (define make-some-frame (fn (f remaining env) {:env env :type "some" :f f :remaining remaining})) +;; Delimited continuations (shift/reset) (define make-every-frame (fn (f remaining env) {:env env :type "every" :f f :remaining remaining})) -;; Delimited continuations (shift/reset) (define make-scope-frame (fn (name remaining env) {:env env :type "scope" :remaining remaining :name name})) (define make-provide-frame (fn (name value remaining env) {:env env :value value :type "provide" :remaining remaining :name name})) (define make-scope-acc-frame (fn (name value remaining env) {:env env :value (or value nil) :type "scope-acc" :remaining remaining :emitted (list) :name name})) +;; Dynamic wind + reactive signals (define make-reset-frame (fn (env) {:env env :type "reset"})) -;; Dynamic wind + reactive signals (define make-dict-frame (fn (remaining results env) {:env env :results results :type "dict" :remaining remaining})) +;; Undelimited continuations (call/cc) (define make-and-frame (fn (remaining env) {:env env :type "and" :remaining remaining})) -;; Undelimited continuations (call/cc) (define make-or-frame (fn (remaining env) {:env env :type "or" :remaining remaining})) -(define - make-dynamic-wind-frame - (fn (phase body-thunk after-thunk env) {:env env :phase phase :after-thunk after-thunk :type "dynamic-wind" :body-thunk body-thunk})) - ;; HO setup: staged argument evaluation for map/filter/etc. ;; Evaluates args one at a time, then dispatches to the correct ;; HO frame (map, filter, reduce) once all args are ready. +(define + make-dynamic-wind-frame + (fn (phase body-thunk after-thunk env) {:env env :phase phase :after-thunk after-thunk :type "dynamic-wind" :body-thunk body-thunk})) + (define make-reactive-reset-frame (fn (env update-fn first-render?) {:first-render first-render? :update-fn update-fn :env env :type "reactive-reset"})) (define make-callcc-frame (fn (env) {:env env :type "callcc"})) +;; Condition system frames (handler-bind, restart-case, signal) (define make-deref-frame (fn (env) {:env env :type "deref"})) -;; Condition system frames (handler-bind, restart-case, signal) (define make-ho-setup-frame (fn (ho-type remaining-args evaled-args env) {:ho-type ho-type :env env :evaled evaled-args :type "ho-setup" :remaining remaining-args})) (define make-comp-trace-frame (fn (name file) {:env file :type "comp-trace" :name name})) +;; R7RS exception frames (raise, guard) (define kont-collect-comp-trace (fn @@ -149,30 +159,33 @@ (cons {:file (get frame "file") :name (get frame "name")} (kont-collect-comp-trace (rest kont))) (kont-collect-comp-trace (rest kont))))))) -;; R7RS exception frames (raise, guard) (define make-handler-frame (fn (handlers remaining env) {:env env :type "handler" :f handlers :remaining remaining})) -(define make-restart-frame (fn (restarts remaining env) {:env env :type "restart" :f restarts :remaining remaining})) - ;; ═══════════════════════════════════════════════════════════════ ;; Part 3: Continuation Stack Operations ;; ;; Searching and manipulating the kont list — finding handlers, ;; restarts, scope accumulators, and capturing delimited slices. ;; ═══════════════════════════════════════════════════════════════ +(define make-restart-frame (fn (restarts remaining env) {:env env :type "restart" :f restarts :remaining remaining})) + (define make-signal-return-frame (fn (env saved-kont) {:env env :type "signal-return" :f saved-kont})) (define make-raise-eval-frame (fn (env continuable?) {:scheme continuable? :env env :type "raise-eval"})) (define make-raise-guard-frame (fn (env saved-kont) {:env env :type "raise-guard" :remaining saved-kont})) +;; Basic kont operations (define make-perform-frame (fn (env) {:env env :type "perform"})) -;; Basic kont operations (define make-vm-resume-frame (fn (resume-fn env) {:env env :type "vm-resume" :f resume-fn})) (define make-import-frame (fn (import-set remaining-sets env) {:args import-set :env env :type "import" :remaining remaining-sets})) +(define + make-parameterize-frame + (fn (remaining current-param results body env) {:env env :body body :results results :type "parameterize" :f current-param :remaining remaining})) + (define find-matching-handler (fn @@ -189,6 +202,7 @@ handler-fn (find-matching-handler (rest handlers) condition))))))) +;; Capture frames up to a reset boundary — used by shift (define kont-find-handler (fn @@ -222,7 +236,6 @@ entry (find-named-restart (rest restarts) name)))))) -;; Capture frames up to a reset boundary — used by shift (define kont-find-restart (fn @@ -246,16 +259,16 @@ (define kont-push (fn (frame kont) (cons frame kont))) -(define kont-top (fn (kont) (first kont))) - -(define kont-pop (fn (kont) (rest kont))) - ;; ═══════════════════════════════════════════════════════════════ ;; Part 4: Extension Points & Mutable State ;; ;; Custom special forms registry, render hooks, strict mode. ;; Mutable globals use set! — the transpiler emits OCaml refs. ;; ═══════════════════════════════════════════════════════════════ +(define kont-top (fn (kont) (first kont))) + +(define kont-pop (fn (kont) (rest kont))) + (define kont-empty? (fn (kont) (empty? kont))) (define @@ -279,6 +292,22 @@ (scan (rest k) (append captured (list frame)))))))) (scan kont (list)))) +(define + kont-push-provides + (fn + (pairs env kont) + (if + (empty? pairs) + kont + (let + ((pair (first pairs))) + (kont-push-provides + (rest pairs) + env + (cons + (make-provide-frame (first pair) (nth pair 1) (list) env) + kont)))))) + (define kont-find-provide (fn @@ -350,12 +379,6 @@ ((name :as string) handler) (dict-set! *custom-special-forms* name handler))) -(define *render-check* nil) - -(define *render-fn* nil) - -(define *library-registry* (dict)) - ;; ═══════════════════════════════════════════════════════════════ ;; Part 5: Evaluation Utilities ;; @@ -364,6 +387,15 @@ ;; defmacro, quasiquote), and macro expansion. ;; ═══════════════════════════════════════════════════════════════ ;; Forward declaration — redefined at end of file as CEK entry point +(define *render-check* nil) + +;; Shared param binding for lambda/component calls. +;; Handles &rest collection — used by both call-lambda and continue-with-call. +(define *render-fn* nil) + +(define *library-registry* (dict)) + +;; Component calls: parse keyword args, bind params, TCO thunk (define library-name-key (fn @@ -372,33 +404,30 @@ "." (map (fn (s) (if (symbol? s) (symbol-name s) (str s))) spec)))) -;; Shared param binding for lambda/component calls. -;; Handles &rest collection — used by both call-lambda and continue-with-call. (define library-loaded? (fn (spec) (has-key? *library-registry* (library-name-key spec)))) +;; Cond/case helpers (define library-exports (fn (spec) (get (get *library-registry* (library-name-key spec)) "exports"))) -;; Component calls: parse keyword args, bind params, TCO thunk (define register-library (fn (spec exports) (dict-set! *library-registry* (library-name-key spec) {:exports exports}))) +;; Special form constructors — build state for CEK evaluation (define *io-registry* (dict)) -;; Cond/case helpers (define io-register! (fn (name spec) (dict-set! *io-registry* name spec))) (define io-registered? (fn (name) (has-key? *io-registry* name))) -;; Special form constructors — build state for CEK evaluation (define io-lookup (fn (name) (get *io-registry* name))) (define io-names (fn () (keys *io-registry*))) @@ -429,13 +458,13 @@ (define *strict* false) +;; Quasiquote expansion (define set-strict! (fn (val) (set! *strict* val))) (define *prim-param-types* nil) (define set-prim-param-types! (fn (types) (set! *prim-param-types* types))) -;; Quasiquote expansion (define value-matches-type? (fn @@ -533,6 +562,7 @@ (define eval-expr (fn (expr (env :as dict)) nil)) +;; Macro expansion — expand then re-evaluate the result (define bind-lambda-params (fn @@ -557,6 +587,14 @@ true)) false)))) +;; ═══════════════════════════════════════════════════════════════ +;; Part 6: CEK Machine Core +;; +;; cek-run: trampoline loop — steps until terminal. +;; cek-step: single step — dispatches on phase (eval vs continue). +;; step-eval: evaluates control expression, pushes frames. +;; step-continue: pops a frame, processes result. +;; ═══════════════════════════════════════════════════════════════ (define call-lambda (fn @@ -600,7 +638,6 @@ (env-bind! local "children" children)) (make-thunk (component-body comp) local)))) -;; Macro expansion — expand then re-evaluate the result (define parse-keyword-args (fn @@ -633,12 +670,10 @@ (list kwargs children)))) ;; ═══════════════════════════════════════════════════════════════ -;; Part 6: CEK Machine Core +;; Part 7: Special Form Step Functions ;; -;; cek-run: trampoline loop — steps until terminal. -;; cek-step: single step — dispatches on phase (eval vs continue). -;; step-eval: evaluates control expression, pushes frames. -;; step-continue: pops a frame, processes result. +;; Each step-sf-* handles one special form in the eval phase. +;; They push frames and return new CEK states — never recurse. ;; ═══════════════════════════════════════════════════════════════ (define cond-scheme? @@ -657,6 +692,7 @@ (= (symbol-name (nth c 1)) "=>"))))) clauses))) +;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise (define is-else-clause? (fn @@ -667,6 +703,9 @@ (= (type-of test) "symbol") (or (= (symbol-name test) "else") (= (symbol-name test) ":else")))))) +;; List evaluation — dispatches on head: special forms, macros, +;; higher-order forms, or function calls. This is the main +;; expression dispatcher for the CEK machine. (define sf-named-let (fn @@ -714,12 +753,7 @@ ((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits))) (cek-call loop-fn init-vals)))))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 7: Special Form Step Functions -;; -;; Each step-sf-* handles one special form in the eval phase. -;; They push frames and return new CEK states — never recurse. -;; ═══════════════════════════════════════════════════════════════ +;; call/cc: capture entire kont as undelimited escape continuation (define sf-lambda (fn @@ -749,7 +783,6 @@ params-expr))) (make-lambda param-names body env)))) -;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise (define sf-defcomp (fn @@ -787,9 +820,6 @@ (env-bind! env (symbol-name name-sym) comp) comp)))) -;; List evaluation — dispatches on head: special forms, macros, -;; higher-order forms, or function calls. This is the main -;; expression dispatcher for the CEK machine. (define defcomp-kwarg (fn @@ -812,7 +842,7 @@ (range 2 end 1)) result))) -;; call/cc: capture entire kont as undelimited escape continuation +;; Pattern matching (match form) (define parse-comp-params (fn @@ -859,6 +889,7 @@ params-expr) (list params has-children param-types)))) +;; Condition system special forms (define sf-defisland (fn @@ -896,7 +927,6 @@ (dict-set! spec (keyword-name (first remaining)) (nth remaining 1)) (defio-parse-kwargs! spec (rest (rest remaining)))))) -;; Pattern matching (match form) (define sf-defio (fn @@ -908,7 +938,6 @@ (io-register! name spec) spec))) -;; Condition system special forms (define sf-defmacro (fn @@ -1113,25 +1142,35 @@ (fn ((mac :as macro) (raw-args :as list) (env :as dict)) (let - ((local (env-merge (macro-closure mac) env))) - (for-each - (fn - (pair) - (env-bind! - local - (first pair) - (if - (< (nth pair 1) (len raw-args)) - (nth raw-args (nth pair 1)) - nil))) - (map-indexed (fn (i p) (list p i)) (macro-params mac))) - (when - (macro-rest-param mac) - (env-bind! - local - (macro-rest-param mac) - (slice raw-args (len (macro-params mac))))) - (trampoline (eval-expr (macro-body mac) local))))) + ((body (macro-body mac))) + (if + (and (symbol? body) (= (symbol-name body) "__syntax-rules-body__")) + (let + ((closure (macro-closure mac))) + (syntax-rules-expand + (env-get closure "__sr-literals") + (env-get closure "__sr-rules") + raw-args)) + (let + ((local (env-merge (macro-closure mac) env))) + (for-each + (fn + (pair) + (env-bind! + local + (first pair) + (if + (< (nth pair 1) (len raw-args)) + (nth raw-args (nth pair 1)) + nil))) + (map-indexed (fn (i p) (list p i)) (macro-params mac))) + (when + (macro-rest-param mac) + (env-bind! + local + (macro-rest-param mac) + (slice raw-args (len (macro-params mac))))) + (trampoline (eval-expr (macro-body mac) local))))))) (define cek-step-loop @@ -1172,6 +1211,7 @@ (step-eval state) (step-continue state)))) +;; Scope/provide/context — structured downward data passing (define step-eval (fn @@ -1310,7 +1350,27 @@ env kont)))) -;; Scope/provide/context — structured downward data passing +(define + step-sf-case + (fn + (args env kont) + (make-cek-state + (first args) + env + (kont-push (make-case-frame nil (rest args) env) kont)))) + +;; ═══════════════════════════════════════════════════════════════ +;; R7RS syntax-rules / define-syntax +;; +;; syntax-rules creates a macro transformer via pattern matching. +;; define-syntax binds the transformer as a macro (reuses define). +;; Pattern language: _ (wildcard), literals (exact match), +;; pattern variables (bind), ... (ellipsis/repetition). +;; ═══════════════════════════════════════════════════════════════ + +;; Match a syntax-rules pattern against a form. +;; Returns a dict of bindings on success, nil on failure. +;; literals is a list of symbol name strings that must match exactly. (define step-eval-list (fn @@ -1410,6 +1470,9 @@ ("quasiquote" (make-cek-value (qq-expand (first args) env) env kont)) ("->" (step-sf-thread-first args env kont)) + ("->>" (step-sf-thread-last args env kont)) + ("|>" (step-sf-thread-last args env kont)) + ("as->" (step-sf-thread-as args env kont)) ("set!" (step-sf-set! args env kont)) ("letrec" (step-sf-letrec args env kont)) ("reset" (step-sf-reset args env kont)) @@ -1448,6 +1511,10 @@ ("import" (step-sf-import args env kont)) ("define-record-type" (make-cek-value (sf-define-record-type args env) env kont)) + ("parameterize" (step-sf-parameterize args env kont)) + ("syntax-rules" + (make-cek-value (sf-syntax-rules args env) env kont)) + ("define-syntax" (step-sf-define args env kont)) (_ (cond (has-key? *custom-special-forms* name) @@ -1464,6 +1531,300 @@ :else (step-eval-call head args env kont))))) (step-eval-call head args env kont)))))) +;; Match a list pattern against a form list, handling ellipsis at any position. +;; pi = pattern index, fi = form index. +(define + step-sf-parameterize + (fn + (args env kont) + (let + ((bindings (first args)) (body (rest args))) + (if + (or (nil? bindings) (empty? bindings)) + (step-sf-begin body env kont) + (let + ((first-pair (first bindings))) + (make-cek-state + (first first-pair) + env + (kont-push + (make-parameterize-frame bindings nil (list) body env) + kont))))))) + +;; Find which pattern variable in a template drives an ellipsis. +;; Returns the variable name (string) whose binding is a list, or nil. +(define + syntax-rules-match + (fn + (pattern form literals) + (cond + (and (symbol? pattern) (= (symbol-name pattern) "_")) + (dict) + (and (symbol? pattern) (contains? literals (symbol-name pattern))) + (if + (and (symbol? form) (= (symbol-name pattern) (symbol-name form))) + (dict) + nil) + (symbol? pattern) + (let ((d (dict))) (dict-set! d (symbol-name pattern) form) d) + (and (list? pattern) (empty? pattern)) + (if (and (list? form) (empty? form)) (dict) nil) + (and (list? pattern) (list? form)) + (syntax-rules-match-list pattern 0 form 0 literals) + :else (if (= pattern form) (dict) nil)))) + +;; Find ALL ellipsis-bound pattern variables in a template. +;; Returns a list of variable name strings. +(define + syntax-rules-match-list + (fn + (pattern pi form fi literals) + (let + ((plen (len pattern)) (flen (len form))) + (cond + (and (>= pi plen) (>= fi flen)) + (dict) + (>= pi plen) + nil + (and + (< (+ pi 1) plen) + (symbol? (nth pattern (+ pi 1))) + (= (symbol-name (nth pattern (+ pi 1))) "...")) + (let + ((sub-pat (nth pattern pi)) + (rest-pat-count (- plen (+ pi 2))) + (available (- flen fi)) + (n-ellipsis (- (- flen fi) (- plen (+ pi 2))))) + (if + (< n-ellipsis 0) + nil + (let + ((ellipsis-forms (slice form fi (+ fi n-ellipsis))) + (sub-bindings + (map + (fn (f) (syntax-rules-match sub-pat f literals)) + (slice form fi (+ fi n-ellipsis))))) + (if + (contains? sub-bindings nil) + nil + (let + ((rest-result (syntax-rules-match-list pattern (+ pi 2) form (+ fi n-ellipsis) literals))) + (if + (nil? rest-result) + nil + (let + ((merged (dict))) + (for-each + (fn + (b) + (for-each + (fn + (key) + (let + ((existing (dict-get merged key))) + (if + (nil? existing) + (dict-set! merged key (list (get b key))) + (dict-set! + merged + key + (append existing (list (get b key))))))) + (keys b))) + sub-bindings) + (for-each + (fn + (key) + (dict-set! merged key (get rest-result key))) + (keys rest-result)) + merged))))))) + (>= fi flen) + nil + :else (let + ((sub-result (syntax-rules-match (nth pattern pi) (nth form fi) literals))) + (if + (nil? sub-result) + nil + (let + ((rest-result (syntax-rules-match-list pattern (+ pi 1) form (+ fi 1) literals))) + (if + (nil? rest-result) + nil + (do + (for-each + (fn + (key) + (dict-set! rest-result key (get sub-result key))) + (keys sub-result)) + rest-result))))))))) + +;; Instantiate a template with pattern variable bindings. +;; Handles ellipsis repetition and recursive substitution. +(define + syntax-rules-find-var + (fn + (template bindings) + (cond + (and + (symbol? template) + (has-key? bindings (symbol-name template)) + (list? (get bindings (symbol-name template)))) + (symbol-name template) + (list? template) + (reduce + (fn + (found t) + (if (nil? found) (syntax-rules-find-var t bindings) found)) + nil + template) + :else nil))) + +;; Walk a template list, handling ellipsis at any position. +;; When element at i is followed by ... at i+1, expand the element +;; for each value of its ellipsis variables (all cycled in parallel). +(define + syntax-rules-find-all-vars + (fn + (template bindings) + (cond + (and + (symbol? template) + (has-key? bindings (symbol-name template)) + (list? (get bindings (symbol-name template)))) + (list (symbol-name template)) + (list? template) + (reduce + (fn (acc t) (append acc (syntax-rules-find-all-vars t bindings))) + (list) + template) + :else (list)))) + +;; Try each syntax-rules clause against a form. +;; Returns the instantiated template for the first matching rule, or errors. +;; form is the raw args (without macro name). We prepend a dummy _ symbol +;; because syntax-rules patterns include the keyword as the first element. +(define + syntax-rules-instantiate + (fn + (template bindings) + (cond + (and (symbol? template) (has-key? bindings (symbol-name template))) + (get bindings (symbol-name template)) + (not (list? template)) + template + (empty? template) + template + :else (syntax-rules-instantiate-list template 0 bindings)))) + +(define + syntax-rules-instantiate-list + (fn + (template i bindings) + (if + (>= i (len template)) + (list) + (let + ((elem (nth template i)) + (has-ellipsis + (and + (< (+ i 1) (len template)) + (symbol? (nth template (+ i 1))) + (= (symbol-name (nth template (+ i 1))) "...")))) + (if + has-ellipsis + (let + ((all-vars (syntax-rules-find-all-vars elem bindings))) + (if + (empty? all-vars) + (syntax-rules-instantiate-list template (+ i 2) bindings) + (let + ((count (len (get bindings (first all-vars)))) + (expanded + (map + (fn + (idx) + (let + ((b (dict))) + (for-each + (fn (key) (dict-set! b key (get bindings key))) + (keys bindings)) + (for-each + (fn + (var-name) + (dict-set! + b + var-name + (nth (get bindings var-name) idx))) + all-vars) + (syntax-rules-instantiate elem b))) + (range count))) + (rest-result + (syntax-rules-instantiate-list template (+ i 2) bindings))) + (append expanded rest-result)))) + (cons + (syntax-rules-instantiate elem bindings) + (syntax-rules-instantiate-list template (+ i 1) bindings))))))) + +;; Special form: (syntax-rules (literal ...) (pattern template) ...) +;; Creates a Macro with rules/literals stored in closure env. +;; Body is a marker symbol; expand-macro detects it and calls +;; the pattern matcher directly. +(define + syntax-rules-expand + (fn + (literals rules form) + (let + ((full-form (cons (make-symbol "_") form))) + (syntax-rules-try-rules literals rules full-form)))) + +(define + syntax-rules-try-rules + (fn + (literals rules full-form) + (if + (empty? rules) + (error + (str "syntax-rules: no pattern matched for " (inspect full-form))) + (let + ((rule (first rules)) + (pattern (first rule)) + (template (nth rule 1))) + (let + ((bindings (syntax-rules-match pattern full-form literals))) + (if + (not (nil? bindings)) + (syntax-rules-instantiate template bindings) + (syntax-rules-try-rules literals (rest rules) full-form))))))) + +;; R7RS records (SRFI-9) +;; +;; (define-record-type +;; (make-point x y) +;; point? +;; (x point-x) +;; (y point-y set-point-y!)) +;; +;; Creates: constructor, predicate, accessors, optional mutators. +;; Opaque — only accessible through generated functions. +;; Generative — each call creates a unique type. +(define + sf-syntax-rules + (fn + (args env) + (let + ((literals (if (list? (first args)) (map (fn (s) (if (symbol? s) (symbol-name s) (str s))) (first args)) (list))) + (rules (rest args))) + (let + ((closure (env-extend env))) + (env-bind! closure "__sr-literals" literals) + (env-bind! closure "__sr-rules" rules) + (make-macro + (list) + "__sr-form" + (quote __syntax-rules-body__) + closure + "syntax-rules"))))) + +;; Delimited continuations (define step-sf-define-library (fn @@ -1539,6 +1900,7 @@ (fn (key) (env-bind! env key (get exports key))) (keys exports)))))))) +;; Signal dereferencing with reactive dependency tracking (define step-sf-import (fn @@ -1563,6 +1925,13 @@ env (kont-push (make-import-frame import-set rest-sets env) kont)))))))) +;; ═══════════════════════════════════════════════════════════════ +;; Part 8: Call Dispatch +;; +;; cek-call: invoke a function from native code (runs a nested +;; trampoline). step-eval-call: CEK-native call dispatch for +;; lambda, component, native fn, and continuations. +;; ═══════════════════════════════════════════════════════════════ (define step-sf-perform (fn @@ -1575,17 +1944,7 @@ env (kont-push (make-perform-frame env) kont))))) -;; R7RS records (SRFI-9) -;; -;; (define-record-type -;; (make-point x y) -;; point? -;; (x point-x) -;; (y point-y set-point-y!)) -;; -;; Creates: constructor, predicate, accessors, optional mutators. -;; Opaque — only accessible through generated functions. -;; Generative — each call creates a unique type. +;; Reactive signal tracking — captures dependency continuation for re-render (define sf-define-record-type (fn @@ -1598,11 +1957,7 @@ (let ((raw-name (symbol-name type-sym))) (let - ((type-name - (if - (and (starts-with? raw-name "<") (ends-with? raw-name ">")) - (slice raw-name 1 (- (len raw-name) 1)) - raw-name)) + ((type-name (if (and (starts-with? raw-name "<") (ends-with? raw-name ">")) (slice raw-name 1 (- (len raw-name) 1)) raw-name)) (ctor-name (symbol-name (first ctor-spec))) (ctor-params (map (fn (s) (symbol-name s)) (rest ctor-spec))) (pred-name (symbol-name pred-sym)) @@ -1610,30 +1965,22 @@ (map (fn (fs) (symbol-name (first fs))) field-specs))) (let ((rtd-uid (make-rtd type-name field-names ctor-params))) - ;; Constructor — OCaml returns a NativeFn - (env-bind! env ctor-name - (make-record-constructor rtd-uid)) - ;; Predicate — OCaml returns a NativeFn - (env-bind! env pred-name - (make-record-predicate rtd-uid)) - ;; Accessors and optional mutators + (env-bind! env ctor-name (make-record-constructor rtd-uid)) + (env-bind! env pred-name (make-record-predicate rtd-uid)) (for-each-indexed (fn (idx fs) (let ((accessor-name (symbol-name (nth fs 1)))) - (env-bind! env accessor-name - (make-record-accessor idx)) + (env-bind! env accessor-name (make-record-accessor idx)) (when (>= (len fs) 3) (let ((mutator-name (symbol-name (nth fs 2)))) - (env-bind! env mutator-name - (make-record-mutator idx)))))) + (env-bind! env mutator-name (make-record-mutator idx)))))) field-specs) nil)))))) -;; Delimited continuations (define step-sf-callcc (fn @@ -1643,6 +1990,13 @@ env (kont-push (make-callcc-frame env) kont)))) +;; ═══════════════════════════════════════════════════════════════ +;; Part 9: Higher-Order Form Machinery +;; +;; Data-first HO forms: (map coll fn) and (map fn coll) both work. +;; ho-swap-args auto-detects argument order. HoSetupFrame stages +;; argument evaluation, then dispatches to the appropriate step-ho-*. +;; ═══════════════════════════════════════════════════════════════ (define match-find-clause (fn @@ -1660,7 +2014,6 @@ (list local body) (match-find-clause val (rest clauses) env)))))) -;; Signal dereferencing with reactive dependency tracking (define match-pattern (fn @@ -1693,13 +2046,6 @@ pairs))) :else (= pattern value)))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 8: Call Dispatch -;; -;; cek-call: invoke a function from native code (runs a nested -;; trampoline). step-eval-call: CEK-native call dispatch for -;; lambda, component, native fn, and continuations. -;; ═══════════════════════════════════════════════════════════════ (define step-sf-match (fn @@ -1714,7 +2060,6 @@ (error (str "match: no clause matched " (inspect val))) (make-cek-state (nth result 1) (first result) kont)))))) -;; Reactive signal tracking — captures dependency continuation for re-render (define step-sf-handler-bind (fn @@ -1762,13 +2107,6 @@ env (kont-push (make-restart-frame restarts (list) env) kont))))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 9: Higher-Order Form Machinery -;; -;; Data-first HO forms: (map coll fn) and (map fn coll) both work. -;; ho-swap-args auto-detects argument order. HoSetupFrame stages -;; argument evaluation, then dispatches to the appropriate step-ho-*. -;; ═══════════════════════════════════════════════════════════════ (define step-sf-signal (fn @@ -1896,6 +2234,14 @@ (make-let-frame vname rest-bindings body local) kont))))))))) +;; ═══════════════════════════════════════════════════════════════ +;; Part 10: Continue Phase — Frame Dispatch +;; +;; When phase="continue", pop the top frame and process the value. +;; Each frame type has its own handling: if frames check truthiness, +;; let frames bind the value, arg frames accumulate it, etc. +;; continue-with-call handles the final function/component dispatch. +;; ═══════════════════════════════════════════════════════════════ (define step-sf-define (fn @@ -1934,6 +2280,9 @@ effect-list) kont))))) +;; Final call dispatch from arg frame — all args evaluated, invoke function. +;; Handles: lambda (bind params + TCO), component (keyword args + TCO), +;; native fn (direct call), continuation (resume), callcc continuation (escape). (define step-sf-set! (fn @@ -1955,6 +2304,13 @@ env (kont-push (make-and-frame (rest args) env) kont))))) +;; ═══════════════════════════════════════════════════════════════ +;; Part 11: Entry Points +;; +;; eval-expr-cek / trampoline-cek: CEK evaluation entry points. +;; eval-expr / trampoline: top-level bindings that override the +;; forward declarations from Part 5. +;; ═══════════════════════════════════════════════════════════════ (define step-sf-or (fn @@ -2000,26 +2356,6 @@ env (kont-push (make-cond-frame args env false) kont))))))))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 10: Continue Phase — Frame Dispatch -;; -;; When phase="continue", pop the top frame and process the value. -;; Each frame type has its own handling: if frames check truthiness, -;; let frames bind the value, arg frames accumulate it, etc. -;; continue-with-call handles the final function/component dispatch. -;; ═══════════════════════════════════════════════════════════════ -(define - step-sf-case - (fn - (args env kont) - (make-cek-state - (first args) - env - (kont-push (make-case-frame nil (rest args) env) kont)))) - -;; Final call dispatch from arg frame — all args evaluated, invoke function. -;; Handles: lambda (bind params + TCO), component (keyword args + TCO), -;; native fn (direct call), continuation (resume), callcc continuation (escape). (define step-sf-thread-first (fn @@ -2027,19 +2363,34 @@ (make-cek-state (first args) env - (kont-push (make-thread-frame (rest args) env) kont)))) + (kont-push (make-thread-frame (rest args) env "first" nil) kont)))) + +(define + step-sf-thread-last + (fn + (args env kont) + (make-cek-state + (first args) + env + (kont-push (make-thread-frame (rest args) env "last" nil) kont)))) + +(define + step-sf-thread-as + (fn + (args env kont) + (let + ((init (first args)) + (name (nth args 1)) + (forms (rest (rest args)))) + (make-cek-state + init + env + (kont-push (make-thread-frame forms env "as" name) kont))))) (define step-sf-lambda (fn (args env kont) (make-cek-value (sf-lambda args env) env kont))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 11: Entry Points -;; -;; eval-expr-cek / trampoline-cek: CEK evaluation entry points. -;; eval-expr / trampoline: top-level bindings that override the -;; forward declarations from Part 5. -;; ═══════════════════════════════════════════════════════════════ (define step-sf-scope (fn @@ -2670,7 +3021,9 @@ ("thread" (let ((remaining (get frame "remaining")) - (fenv (get frame "env"))) + (fenv (get frame "env")) + (mode (get frame "extra")) + (bind-name (get frame "name"))) (if (empty? remaining) (make-cek-value value fenv rest-k) @@ -2682,9 +3035,18 @@ (empty? (rest remaining)) rest-k (kont-push - (make-thread-frame (rest remaining) fenv) + (make-thread-frame + (rest remaining) + fenv + mode + bind-name) rest-k)))) - (if + (cond + (= mode "as") + (let + ((new-env (env-extend fenv))) + (env-bind! new-env (symbol-name bind-name) value) + (make-cek-state form new-env new-kont)) (and (= (type-of form) "list") (not (empty? form)) @@ -2696,7 +3058,23 @@ (cons (list (quote quote) value) (rest form))) fenv new-kont) + (= mode "last") (let + ((result (thread-insert-arg-last form value fenv))) + (if + (empty? rest-forms) + (make-cek-value result fenv rest-k) + (make-cek-value + result + fenv + (kont-push + (make-thread-frame + rest-forms + fenv + mode + bind-name) + rest-k)))) + :else (let ((result (thread-insert-arg form value fenv))) (if (empty? rest-forms) @@ -2705,7 +3083,11 @@ result fenv (kont-push - (make-thread-frame rest-forms fenv) + (make-thread-frame + rest-forms + fenv + mode + bind-name) rest-k))))))))) ("arg" (let @@ -3131,6 +3513,55 @@ (empty? remaining-sets) (make-cek-value nil fenv rest-k) (step-sf-import remaining-sets fenv rest-k))))) + ("parameterize" + (let + ((remaining (get frame "remaining")) + (current-param (get frame "f")) + (results (get frame "results")) + (body (get frame "body")) + (fenv (get frame "env"))) + (if + (nil? current-param) + (let + ((param-obj value) + (val-expr (nth (first remaining) 1))) + (make-cek-state + val-expr + fenv + (kont-push + (make-parameterize-frame + remaining + param-obj + results + body + fenv) + rest-k))) + (let + ((converted-val value) + (new-results + (append + results + (list + (list (parameter-uid current-param) converted-val)))) + (rest-bindings (rest remaining))) + (if + (empty? rest-bindings) + (let + ((body-expr (if (= (len body) 1) (first body) (cons (quote begin) body))) + (provide-kont + (kont-push-provides new-results fenv rest-k))) + (make-cek-state body-expr fenv provide-kont)) + (make-cek-state + (first (first rest-bindings)) + fenv + (kont-push + (make-parameterize-frame + rest-bindings + nil + new-results + body + fenv) + rest-k))))))) (_ (do (set! *last-error-kont* rest-k) @@ -3141,6 +3572,13 @@ (fn (f args env raw-args kont) (cond + (parameter? f) + (let + ((uid (parameter-uid f)) (frame (kont-find-provide kont uid))) + (make-cek-value + (if frame (get frame "value") (parameter-default f)) + env + kont)) (callcc-continuation? f) (let ((arg (if (empty? args) nil (first args)))