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)))