diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index c92a82f4..04b3b26d 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -86,6 +86,10 @@ and make_let_frame name remaining body local = and make_define_frame name env has_effects effect_list = (CekFrame { cf_type = "define"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = has_effects; cf_extra2 = effect_list }) +(* make-define-foreign-frame *) +and make_define_foreign_frame name spec env = + (CekFrame { cf_type = "define-foreign"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) + (* make-set-frame *) and make_set_frame name env = (CekFrame { cf_type = "set"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) @@ -332,18 +336,23 @@ and render_fn = (* *bind-tracking* *) and _bind_tracking_ref = ref Nil -and _bind_tracking_ = Nil +and _bind_tracking_ = + Nil (* *provide-batch-depth* *) and _provide_batch_depth_ref = ref (Number 0.0) -and _provide_batch_depth_ = (Number 0.0) +and _provide_batch_depth_ = + (Number 0.0) (* *provide-batch-queue* *) and _provide_batch_queue_ref = ref (List []) -and _provide_batch_queue_ = (List []) +and _provide_batch_queue_ = + (List []) (* *provide-subscribers* *) -and _provide_subscribers_ref = ref (Dict (Hashtbl.create 8)) +and _provide_subscribers_ref = ref (Dict (Hashtbl.create 0)) +and _provide_subscribers_ = + (Dict (Hashtbl.create 0)) (* *library-registry* *) and _library_registry_ = @@ -385,21 +394,79 @@ and io_lookup name = and io_names () = (prim_call "keys" [_io_registry_]) +(* *foreign-registry* *) +and _foreign_registry_ = + (Dict (Hashtbl.create 0)) + +(* foreign-register! *) +and foreign_register_b name spec = + (sx_dict_set_b _foreign_registry_ name spec) + +(* foreign-registered? *) +and foreign_registered_p name = + (prim_call "has-key?" [_foreign_registry_; name]) + +(* foreign-lookup *) +and foreign_lookup name = + (get (_foreign_registry_) (name)) + +(* foreign-names *) +and foreign_names () = + (prim_call "keys" [_foreign_registry_]) + +(* foreign-parse-params *) +and foreign_parse_params param_list = + (let result' = (List []) in let i = (Number 0.0) in let items = (if sx_truthy ((list_p (param_list))) then param_list else (List [])) in (foreign_parse_params_loop (items) (result'))) + +(* foreign-parse-kwargs! *) +and foreign_parse_kwargs_b spec remaining = + (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (remaining)))))) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (remaining)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (keyword_p ((first (remaining))))))) then (let () = ignore ((sx_dict_set_b spec (keyword_name ((first (remaining)))) (let v = (nth (remaining) ((Number 1.0))) in (if sx_truthy ((keyword_p (v))) then (keyword_name (v)) else v)))) in (foreign_parse_kwargs_b (spec) ((rest ((rest (remaining))))))) else Nil) + +(* foreign-resolve-binding *) +and foreign_resolve_binding binding_str = + (let parts = (prim_call "split" [binding_str; (String ".")]) in (if sx_truthy ((prim_call "<=" [(len (parts)); (Number 1.0)])) then (let _d = Hashtbl.create 2 in Hashtbl.replace _d "method" binding_str; Hashtbl.replace _d "object" Nil; Dict _d) else (let method' = (last (parts)) in let obj = (prim_call "join" [(String "."); (reverse ((rest ((reverse (parts))))))]) in (let _d = Hashtbl.create 2 in Hashtbl.replace _d "method" method'; Hashtbl.replace _d "object" obj; Dict _d)))) + +(* foreign-check-args *) +and foreign_check_args name params args = + (let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (params)))))) in if not (sx_truthy _and) then _and else (prim_call "<" [(len (args)); (len (params))]))) then (raise (Eval_error (value_to_str (String (sx_str [(String "foreign "); name; (String ": expected "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (List.iter (fun i -> ignore ((let spec = (nth (params) (i)) in let val' = (nth (args) (i)) in let expected = (get (spec) ((String "type"))) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((prim_call "=" [expected; (String "any")]))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((value_matches_type_p (val') (expected)))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "foreign "); name; (String ": arg '"); (get (spec) ((String "name"))); (String "' expected "); expected; (String ", got "); (type_of (val'))]))))) else Nil)))) (sx_to_list (prim_call "range" [(Number 0.0); (prim_call "min" [(len (params)); (len (args))])])); Nil)) + +(* foreign-build-lambda *) +and foreign_build_lambda spec = + (let name = (get (spec) ((String "name"))) in let mode = (if sx_truthy ((prim_call "has-key?" [spec; (String "returns")])) then (let r = (get (spec) ((String "returns"))) in (if sx_truthy ((prim_call "=" [r; (String "promise")])) then (String "async") else (String "sync"))) else (String "sync")) in (if sx_truthy ((prim_call "=" [mode; (String "async")])) then (List [(Symbol "fn"); (List [(Symbol "&rest"); (Symbol "__ffi-args__")]); (List [(Symbol "perform"); (List [(Symbol "foreign-dispatch"); (List [(Symbol "quote"); name]); (Symbol "__ffi-args__")])])]) else (List [(Symbol "fn"); (List [(Symbol "&rest"); (Symbol "__ffi-args__")]); (List [(Symbol "foreign-dispatch"); (List [(Symbol "quote"); name]); (Symbol "__ffi-args__")])]))) + +(* sf-define-foreign *) +and sf_define_foreign args env = + (let name = (if sx_truthy ((symbol_p ((first (args))))) then (symbol_name ((first (args)))) else (first (args))) in let param_list = (nth (args) ((Number 1.0))) in let spec = (Dict (Hashtbl.create 0)) in (let () = ignore ((sx_dict_set_b spec (String "name") name)) in (let () = ignore ((sx_dict_set_b spec (String "params") (foreign_parse_params (param_list)))) in (let () = ignore ((foreign_parse_kwargs_b (spec) ((rest ((rest (args))))))) in (let () = ignore ((foreign_register_b (name) (spec))) in spec))))) + +(* step-sf-define-foreign *) +and step_sf_define_foreign args env kont = + (let spec = (sf_define_foreign (args) (env)) in let name = (if sx_truthy ((symbol_p ((first (args))))) then (symbol_name ((first (args)))) else (first (args))) in let lambda_expr = (foreign_build_lambda (spec)) in (make_cek_state (lambda_expr) (env) ((kont_push ((make_define_foreign_frame (name) (spec) (env))) (kont))))) + +(* foreign-dispatch *) +and foreign_dispatch name args = + (let spec = (foreign_lookup (name)) in (let () = ignore ((if sx_truthy ((is_nil (spec))) then (raise (Eval_error (value_to_str (String (sx_str [(String "foreign-dispatch: unknown foreign function '"); name; (String "'")]))))) else Nil)) in (let params = (get (spec) ((String "params"))) in let binding = (get (spec) ((String "js"))) in (let () = ignore ((foreign_check_args (name) ((if sx_truthy ((is_nil (params))) then (List []) else params)) (args))) in (if sx_truthy ((is_nil (binding))) then (raise (Eval_error (value_to_str (String (sx_str [(String "foreign "); name; (String ": no binding for current platform")]))))) else (let resolved = (foreign_resolve_binding (binding)) in let obj_name = (get (resolved) ((String "object"))) in let method' = (get (resolved) ((String "method"))) in (if sx_truthy ((is_primitive ((String "host-call")))) then (if sx_truthy ((is_nil (obj_name))) then (sx_apply (get_primitive ((String "host-call"))) (prim_call "concat" [(List [Nil; method']); args])) else (let obj = (cek_call ((get_primitive ((String "host-global")))) (List [obj_name])) in (sx_apply (get_primitive ((String "host-call"))) (prim_call "concat" [(List [obj; method']); args])))) else (raise (Eval_error (value_to_str (String (sx_str [(String "foreign "); name; (String ": host-call not available on this platform")])))))))))))) + +(* foreign-parse-params-loop *) +and foreign_parse_params_loop items acc = + (if sx_truthy ((empty_p (items))) then acc else (let item = (first (items)) in let rest_items = (rest (items)) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (rest_items)))))) in if not (sx_truthy _and) then _and else (let _and = (keyword_p ((first (rest_items)))) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(keyword_name ((first (rest_items)))); (String "as")]) in if not (sx_truthy _and) then _and else (prim_call ">=" [(len (rest_items)); (Number 2.0)]))))) then (foreign_parse_params_loop ((rest ((rest (rest_items))))) ((prim_call "append" [acc; (List [(let _d = Hashtbl.create 2 in Hashtbl.replace _d "type" (let t = (nth (rest_items) ((Number 1.0))) in (if sx_truthy ((keyword_p (t))) then (keyword_name (t)) else (String (sx_str [t])))); Hashtbl.replace _d "name" (if sx_truthy ((symbol_p (item))) then (symbol_name (item)) else (String (sx_str [item]))); Dict _d)])]))) else (foreign_parse_params_loop (rest_items) ((prim_call "append" [acc; (List [(CekFrame { cf_type = "any"; cf_env = Nil; cf_name = (if sx_truthy ((symbol_p (item))) then (symbol_name (item)) else (String (sx_str [item]))); cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })])])))))) + (* step-sf-io *) and step_sf_io args env kont = (let name = (first (args)) in let io_args = (rest (args)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((io_registered_p (name))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "io: unknown operation '"); name; (String "' — not in *io-registry*")]))))) else Nil)) in (make_cek_state ((cons ((Symbol "perform")) ((List [(let _d = Hashtbl.create 2 in Hashtbl.replace _d "args" io_args; Hashtbl.replace _d "op" name; Dict _d)])))) (env) (kont)))) (* *strict* *) +and _strict_ref = ref (Bool false) and _strict_ = - !_strict_ref + (Bool false) (* set-strict! *) and set_strict_b val' = let _strict_ = ref Nil in (_strict_ref := val'; Nil) (* *prim-param-types* *) +and _prim_param_types_ref = ref Nil and _prim_param_types_ = - !_prim_param_types_ref + Nil (* set-prim-param-types! *) and set_prim_param_types_b types = @@ -547,7 +614,7 @@ and step_sf_let_match 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 "->>")])) 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 "peek")])) then (step_sf_peek (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide!")])) then (step_sf_provide_b (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 "bind")])) then (step_sf_bind (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 "let-match")])) then (step_sf_let_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 "define-protocol")])) then (make_cek_value ((sf_define_protocol (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "implement")])) then (make_cek_value ((sf_implement (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))))) + (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 "define-foreign")])) then (step_sf_define_foreign (args) (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 "peek")])) then (step_sf_peek (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide!")])) then (step_sf_provide_b (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 "bind")])) then (step_sf_bind (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 "let-match")])) then (step_sf_let_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 "define-protocol")])) then (make_cek_value ((sf_define_protocol (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "implement")])) then (make_cek_value ((sf_implement (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))))) (* kont-extract-provides *) and kont_extract_provides kont = @@ -555,19 +622,19 @@ and kont_extract_provides kont = (* fire-provide-subscribers *) and fire_provide_subscribers name = - let _provide_batch_queue_ = _provide_batch_queue_ref in (let subs = (get (!_provide_subscribers_ref) (name)) in (if sx_truthy ((let _and = subs in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((empty_p (subs)))))))) then (if sx_truthy ((prim_call ">" [!_provide_batch_depth_ref; (Number 0.0)])) then (List.iter (fun sub -> ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_provide_batch_queue_; sub])))))) then (_provide_batch_queue_ := sx_append_b !_provide_batch_queue_ sub; Nil) else Nil))) (sx_to_list subs); Nil) else (List.iter (fun sub -> ignore ((cek_call (sub) ((List [Nil]))))) (sx_to_list subs); Nil)) else Nil)) + let _provide_batch_queue_ = ref Nil in (let subs = (get (!_provide_subscribers_ref) (name)) in (if sx_truthy ((let _and = subs in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((empty_p (subs)))))))) then (if sx_truthy ((prim_call ">" [!_provide_batch_depth_ref; (Number 0.0)])) then (List.iter (fun sub -> ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_provide_batch_queue_ref; sub])))))) then (_provide_batch_queue_ := sx_append_b !_provide_batch_queue_ sub; Nil) else Nil))) (sx_to_list subs); Nil) else (List.iter (fun sub -> ignore ((cek_call (sub) ((List [Nil]))))) (sx_to_list subs); Nil)) else Nil)) (* batch-begin! *) and batch_begin_b () = - let _provide_batch_depth_ = _provide_batch_depth_ref in (_provide_batch_depth_ := (prim_call "+" [!_provide_batch_depth_; (Number 1.0)]); Nil) + let _provide_batch_depth_ = ref Nil in (_provide_batch_depth_ref := (prim_call "+" [!_provide_batch_depth_ref; (Number 1.0)]); Nil) (* batch-end! *) and batch_end_b () = - let _provide_batch_depth_ = _provide_batch_depth_ref in let _provide_batch_queue_ = _provide_batch_queue_ref in (let () = ignore ((_provide_batch_depth_ := (prim_call "-" [!_provide_batch_depth_; (Number 1.0)]); Nil)) in (if sx_truthy ((prim_call "=" [!_provide_batch_depth_; (Number 0.0)])) then (let queue = !_provide_batch_queue_ in (let () = ignore ((_provide_batch_queue_ := (List []); Nil)) in (List.iter (fun sub -> ignore ((cek_call (sub) ((List [Nil]))))) (sx_to_list queue); Nil))) else Nil)) + let _provide_batch_depth_ = ref Nil in let _provide_batch_queue_ = ref Nil in (let () = ignore ((_provide_batch_depth_ref := (prim_call "-" [!_provide_batch_depth_ref; (Number 1.0)]); Nil)) in (if sx_truthy ((prim_call "=" [!_provide_batch_depth_ref; (Number 0.0)])) then (let queue = !_provide_batch_queue_ref in (let () = ignore ((_provide_batch_queue_ref := (List []); Nil)) in (List.iter (fun sub -> ignore ((cek_call (sub) ((List [Nil]))))) (sx_to_list queue); Nil))) else Nil)) (* step-sf-bind *) and step_sf_bind args env kont = - let _bind_tracking_ = _bind_tracking_ref in (let body = (first (args)) in let prev = !_bind_tracking_ref in (let () = ignore ((_bind_tracking_ref := (List []); Nil)) in (make_cek_state (body) (env) ((kont_push ((make_bind_frame (body) (env) (prev))) (kont)))))) + let _bind_tracking_ = ref Nil in (let body = (first (args)) in let prev = !_bind_tracking_ref in (let () = ignore ((_bind_tracking_ref := (List []); Nil)) in (make_cek_state (body) (env) ((kont_push ((make_bind_frame (body) (env) (prev))) (kont)))))) (* step-sf-parameterize *) and step_sf_parameterize args env kont = @@ -611,7 +678,7 @@ and sf_syntax_rules args env = (* step-sf-define-library *) and step_sf_define_library args env kont = - (let lib_spec = (first (args)) in let decls = (rest (args)) in (let lib_env = (env_extend (env)) in let exports = ref ((List [])) in let body_forms = ref ((List [])) in (let () = ignore ((List.iter (fun decl -> ignore ((if sx_truthy ((let _and = (list_p (decl)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (decl)))))) in if not (sx_truthy _and) then _and else (symbol_p ((first (decl))))))) then (let kind = (symbol_name ((first (decl)))) in (if sx_truthy ((prim_call "=" [kind; (String "export")])) then (exports := (prim_call "append" [!exports; (List (List.map (fun s -> (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s])))) (sx_to_list (rest (decl)))))]); Nil) else (if sx_truthy ((prim_call "=" [kind; (String "import")])) then (List.iter (fun import_set -> ignore (bind_import_set import_set lib_env)) (sx_to_list (rest decl)); Nil) else (if sx_truthy ((prim_call "=" [kind; (String "begin")])) then (body_forms := (prim_call "append" [!body_forms; (rest (decl))]); Nil) else Nil)))) else Nil))) (sx_to_list decls); Nil)) in (let () = ignore ((List.iter (fun form -> ignore ((eval_expr (form) (lib_env)))) (sx_to_list !body_forms); Nil)) in (let export_dict = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun name -> ignore ((if sx_truthy ((env_has (lib_env) (name))) then (sx_dict_set_b export_dict name (env_get (lib_env) (name))) else Nil))) (sx_to_list !exports); Nil)) in (let () = ignore ((register_library (lib_spec) (export_dict))) in (make_cek_value (Nil) (env) (kont))))))))) + (let lib_spec = (first (args)) in let decls = (rest (args)) in (let lib_env = (env_extend (env)) in let exports = ref ((List [])) in let body_forms = ref ((List [])) in (let () = ignore ((List.iter (fun decl -> ignore ((if sx_truthy ((let _and = (list_p (decl)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (decl)))))) in if not (sx_truthy _and) then _and else (symbol_p ((first (decl))))))) then (let kind = (symbol_name ((first (decl)))) in (if sx_truthy ((prim_call "=" [kind; (String "export")])) then (exports := (prim_call "append" [!exports; (List (List.map (fun s -> (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s])))) (sx_to_list (rest (decl)))))]); Nil) else (if sx_truthy ((prim_call "=" [kind; (String "import")])) then (List.iter (fun import_set -> ignore ((bind_import_set (import_set) (lib_env)))) (sx_to_list (rest (decl))); Nil) else (if sx_truthy ((prim_call "=" [kind; (String "begin")])) then (body_forms := (prim_call "append" [!body_forms; (rest (decl))]); Nil) else Nil)))) else Nil))) (sx_to_list decls); Nil)) in (let () = ignore ((List.iter (fun form -> ignore ((eval_expr (form) (lib_env)))) (sx_to_list !body_forms); Nil)) in (let export_dict = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun name -> ignore ((if sx_truthy ((env_has (lib_env) (name))) then (sx_dict_set_b export_dict name (env_get (lib_env) (name))) else Nil))) (sx_to_list !exports); Nil)) in (let () = ignore ((register_library (lib_spec) (export_dict))) in (make_cek_value (Nil) (env) (kont))))))))) (* bind-import-set *) and bind_import_set import_set env = @@ -736,7 +803,7 @@ and step_sf_provide args env kont = (* step-sf-context *) and step_sf_context args env kont = - let _bind_tracking_ = _bind_tracking_ref in (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let default_val = (if sx_truthy ((prim_call ">=" [(len (args)); (Number 2.0)])) then (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) else Nil) in let frame = (kont_find_provide (kont) (name)) in (let () = ignore ((if sx_truthy (!_bind_tracking_ref) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_bind_tracking_ref; name])))))) then (_bind_tracking_ := sx_append_b !_bind_tracking_ name; Nil) else Nil) else Nil)) in (make_cek_value ((let sv = (scope_peek (name)) in (if sx_truthy ((is_nil (sv))) then (if sx_truthy (frame) then (get (frame) ((String "value"))) else default_val) else sv))) (env) (kont)))) + let _bind_tracking_ = ref Nil in (let name = (trampoline ((eval_expr ((first (args))) (env)))) in let default_val = (if sx_truthy ((prim_call ">=" [(len (args)); (Number 2.0)])) then (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) else Nil) in let frame = (kont_find_provide (kont) (name)) in (let () = ignore ((if sx_truthy (!_bind_tracking_ref) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!_bind_tracking_ref; name])))))) then (_bind_tracking_ := sx_append_b !_bind_tracking_ name; Nil) else Nil) else Nil)) in (make_cek_value ((let sv = (scope_peek (name)) in (if sx_truthy ((is_nil (sv))) then (if sx_truthy (frame) then (get (frame) ((String "value"))) else default_val) else sv))) (env) (kont)))) (* step-sf-peek *) and step_sf_peek args env kont = @@ -824,7 +891,7 @@ and step_ho_for_each args env kont = (* step-continue *) and step_continue state = - let _bind_tracking_ = _bind_tracking_ref in 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 (let () = ignore ((scope_pop ((get (frame) ((String "name")))))) in (make_cek_value (value) (fenv) (rest_k))) else (let new_frame = (make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "subscribers") (get (frame) ((String "subscribers"))))) in (make_cek_state ((first (remaining))) (fenv) ((kont_push (new_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "bind")])) then (let tracked = !_bind_tracking_ref in let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in let prev = (get (frame) ((String "prev-tracking"))) in (let () = ignore ((_bind_tracking_ref := prev; Nil)) in (let () = ignore ((let subscriber = (NativeFn ("\206\187", fun _args -> match _args with [fire_kont] -> (fun fire_kont -> (cek_run ((make_cek_state (body) (fenv) ((List [])))))) fire_kont | _ -> Nil)) in (List.iter (fun name -> ignore ((let existing = (get (!_provide_subscribers_ref) (name)) in (sx_dict_set_b !_provide_subscribers_ref name (prim_call "append" [(if sx_truthy (existing) then existing else (List [])); (List [subscriber])]))))) (sx_to_list tracked); Nil))) in (make_cek_value (value) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide-set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let target = (kont_find_provide (rest_k) (name)) in (let old_val = (if sx_truthy (target) then (get (target) ((String "value"))) else (scope_peek (name))) in (let () = ignore ((if sx_truthy (target) then (sx_dict_set_b target (String "value") value) else Nil)) in (let () = ignore ((scope_pop (name))) in (let () = ignore ((scope_push (name) (value))) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [old_val; value])))))) then (fire_provide_subscribers (name)) else Nil)) in (make_cek_value (value) (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]))))))))))))))))))))))))))))))))))))))))))))))))))) + let _bind_tracking_ = ref Nil in 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 "define-foreign")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) 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 (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 (let () = ignore ((scope_pop ((get (frame) ((String "name")))))) in (make_cek_value (value) (fenv) (rest_k))) else (let new_frame = (make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "subscribers") (get (frame) ((String "subscribers"))))) in (make_cek_state ((first (remaining))) (fenv) ((kont_push (new_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "bind")])) then (let tracked = !_bind_tracking_ref in let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in let prev = (get (frame) ((String "prev-tracking"))) in (let () = ignore ((_bind_tracking_ref := prev; Nil)) in (let () = ignore ((let subscriber = (NativeFn ("\206\187", fun _args -> match _args with [fire_kont] -> (fun fire_kont -> (cek_run ((make_cek_state (body) (fenv) ((List [])))))) fire_kont | _ -> Nil)) in (List.iter (fun name -> ignore ((let existing = (get (!_provide_subscribers_ref) (name)) in (sx_dict_set_b !_provide_subscribers_ref name (prim_call "append" [(if sx_truthy (existing) then existing else (List [])); (List [subscriber])]))))) (sx_to_list tracked); Nil))) in (make_cek_value (value) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide-set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let target = (kont_find_provide (rest_k) (name)) in (let old_val = (if sx_truthy (target) then (get (target) ((String "value"))) else (scope_peek (name))) in (let () = ignore ((if sx_truthy (target) then (sx_dict_set_b target (String "value") value) else Nil)) in (let () = ignore ((scope_pop (name))) in (let () = ignore ((scope_push (name) (value))) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [old_val; value])))))) then (fire_provide_subscribers (name)) else Nil)) in (make_cek_value (value) (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 = @@ -916,5 +983,3 @@ let enhance_error_with_trace msg = - -let () = Sx_types._cek_call_ref := cek_call diff --git a/hosts/ocaml/transpiler.sx b/hosts/ocaml/transpiler.sx index be4934e9..c8a7e83b 100644 --- a/hosts/ocaml/transpiler.sx +++ b/hosts/ocaml/transpiler.sx @@ -285,7 +285,14 @@ (define ml-mutable-globals - (list "*strict*" "*prim-param-types*" "*last-error-kont*" "*bind-tracking*")) + (list + "*strict*" + "*prim-param-types*" + "*last-error-kont*" + "*bind-tracking*" + "*provide-batch-depth*" + "*provide-batch-queue*" + "*provide-subscribers*")) (define ml-is-mutable-global? @@ -1824,7 +1831,16 @@ "\n"))))) (if (ml-is-mutable-global? name) - (str "let " ml-name " =\n !" ml-name "ref\n") + (str + "let " + ml-name + "ref = ref " + (ml-expr val-expr) + "\nand " + ml-name + " =\n " + (ml-expr val-expr) + "\n") (str "let " ml-name " =\n " (ml-expr val-expr) "\n")))))))) (define @@ -1935,5 +1951,14 @@ "\n"))))) (if (ml-is-mutable-global? name) - (str "let rec " ml-name " =\n !" ml-name "ref\n") + (str + "let rec " + ml-name + "ref = ref " + (ml-expr val-expr) + "\nand " + ml-name + " =\n " + (ml-expr val-expr) + "\n") (str "let rec " ml-name " =\n " (ml-expr val-expr) "\n"))))))) diff --git a/spec/evaluator.sx b/spec/evaluator.sx index acf8adf4..2922b954 100644 --- a/spec/evaluator.sx +++ b/spec/evaluator.sx @@ -49,6 +49,8 @@ (define make-define-frame (fn (name env has-effects effect-list) {:env env :effect-list effect-list :has-effects has-effects :type "define" :name name})) +(define make-define-foreign-frame (fn (name spec env) {:spec spec :env env :type "define-foreign" :name name})) + (define make-set-frame (fn (name env) {:env env :type "set" :name name})) (define @@ -59,9 +61,9 @@ (define make-cond-frame (fn (remaining env scheme?) {:scheme scheme? :env env :type "cond" :remaining remaining})) +;; Higher-order iteration frames (define make-cond-arrow-frame (fn (test-value env) {:env env :match-val test-value :type "cond-arrow"})) -;; 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 mode name) {:env env :type "thread" :extra mode :remaining remaining :name name})) @@ -92,69 +94,69 @@ (define make-multi-map-frame (fn (f remaining-lists results env) {:env env :results results :type "multi-map" :f f :remaining remaining-lists})) +;; Scope/provide/context — downward data passing without env threading (define make-filter-frame (fn (f remaining results current-item env) {:current-item current-item :env env :results results :type "filter" :f f :remaining remaining})) -;; 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})) (define make-for-each-frame (fn (f remaining env) {:env env :type "for-each" :f f :remaining remaining})) +;; Delimited continuations (shift/reset) (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})) (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) {:subscribers (list) :env env :value value :type "provide" :remaining remaining :name name})) +;; Dynamic wind + reactive signals (define make-bind-frame (fn (body env prev-tracking) {:body body :env env :type "bind" :prev-tracking prev-tracking})) -;; Dynamic wind + reactive signals (define make-provide-set-frame (fn (name env) {:env env :type "provide-set" :name name})) +;; Undelimited continuations (call/cc) (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})) -;; Undelimited continuations (call/cc) (define make-reset-frame (fn (env) {:env env :type "reset"})) -(define make-dict-frame (fn (remaining results env) {:env env :results results :type "dict" :remaining remaining})) - ;; 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-dict-frame (fn (remaining results env) {:env env :results results :type "dict" :remaining remaining})) + (define make-and-frame (fn (remaining env) {:env env :type "and" :remaining remaining})) (define make-or-frame (fn (remaining env) {:env env :type "or" :remaining remaining})) +;; Condition system frames (handler-bind, restart-case, signal) (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})) -;; Condition system frames (handler-bind, restart-case, signal) (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"})) +;; R7RS exception frames (raise, guard) (define make-deref-frame (fn (env) {:env env :type "deref"})) -;; R7RS exception frames (raise, guard) (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})) - ;; ═══════════════════════════════════════════════════════════════ ;; Part 3: Continuation Stack Operations ;; ;; Searching and manipulating the kont list — finding handlers, ;; restarts, scope accumulators, and capturing delimited slices. ;; ═══════════════════════════════════════════════════════════════ +(define make-comp-trace-frame (fn (name file) {:env file :type "comp-trace" :name name})) + (define kont-collect-comp-trace (fn @@ -173,9 +175,9 @@ (define make-restart-frame (fn (restarts remaining env) {:env env :type "restart" :f restarts :remaining remaining})) +;; Basic kont operations (define make-signal-return-frame (fn (env saved-kont) {:env env :type "signal-return" :f saved-kont})) -;; Basic kont operations (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})) @@ -184,9 +186,9 @@ (define make-vm-resume-frame (fn (resume-fn env) {:env env :type "vm-resume" :f resume-fn})) +;; Capture frames up to a reset boundary — used by shift (define make-import-frame (fn (import-set remaining-sets env) {:args import-set :env env :type "import" :remaining remaining-sets})) -;; Capture frames up to a reset boundary — used by shift (define make-parameterize-frame (fn (remaining current-param results body env) {:env env :body body :results results :type "parameterize" :f current-param :remaining remaining})) @@ -240,6 +242,12 @@ entry (find-named-restart (rest restarts) name)))))) +;; ═══════════════════════════════════════════════════════════════ +;; 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-find-restart (fn @@ -259,12 +267,6 @@ (list match frame (rest kont)))) (kont-find-restart (rest kont) name)))))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 4: Extension Points & Mutable State -;; -;; Custom special forms registry, render hooks, strict mode. -;; Mutable globals use set! — the transpiler emits OCaml refs. -;; ═══════════════════════════════════════════════════════════════ (define frame-type (fn (f) (get f "type"))) (define kont-push (fn (frame kont) (cons frame kont))) @@ -356,6 +358,14 @@ true (has-reactive-reset-frame? (rest kont)))))) +;; ═══════════════════════════════════════════════════════════════ +;; Part 5: Evaluation Utilities +;; +;; Forward-declared eval-expr, lambda/component calling, keyword +;; arg parsing, special form constructors (lambda, defcomp, +;; defmacro, quasiquote), and macro expansion. +;; ═══════════════════════════════════════════════════════════════ +;; Forward declaration — redefined at end of file as CEK entry point (define kont-capture-to-reactive-reset (fn @@ -375,37 +385,33 @@ (scan (rest k) (append captured (list frame)))))))) (scan kont (list)))) -;; ═══════════════════════════════════════════════════════════════ -;; Part 5: Evaluation Utilities -;; -;; Forward-declared eval-expr, lambda/component calling, keyword -;; arg parsing, special form constructors (lambda, defcomp, -;; defmacro, quasiquote), and macro expansion. -;; ═══════════════════════════════════════════════════════════════ -;; Forward declaration — redefined at end of file as CEK entry point -(define *custom-special-forms* (dict)) - ;; Shared param binding for lambda/component calls. ;; Handles &rest collection — used by both call-lambda and continue-with-call. +(define *custom-special-forms* (dict)) + (define register-special-form! (fn ((name :as string) handler) (dict-set! *custom-special-forms* name handler))) +;; Component calls: parse keyword args, bind params, TCO thunk (define *render-check* nil) -;; Component calls: parse keyword args, bind params, TCO thunk (define *render-fn* nil) +;; Cond/case helpers (define *bind-tracking* nil) -;; Cond/case helpers (define *provide-batch-depth* 0) +;; Special form constructors — build state for CEK evaluation +(define *provide-batch-queue* (list)) + +(define *provide-subscribers* (dict)) + (define *library-registry* (dict)) -;; Special form constructors — build state for CEK evaluation (define library-name-key (fn @@ -432,15 +438,249 @@ (define *io-registry* (dict)) +;; Quasiquote expansion (define io-register! (fn (name spec) (dict-set! *io-registry* name spec))) (define io-registered? (fn (name) (has-key? *io-registry* name))) (define io-lookup (fn (name) (get *io-registry* name))) -;; Quasiquote expansion (define io-names (fn () (keys *io-registry*))) +(define *foreign-registry* (dict)) + +(define + foreign-register! + (fn (name spec) (dict-set! *foreign-registry* name spec))) + +;; Macro expansion — expand then re-evaluate the result +(define foreign-registered? (fn (name) (has-key? *foreign-registry* name))) + +;; ═══════════════════════════════════════════════════════════════ +;; 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 foreign-lookup (fn (name) (get *foreign-registry* name))) + +(define foreign-names (fn () (keys *foreign-registry*))) + +(define + foreign-parse-params + (fn + (param-list) + (let + ((result (list)) + (i 0) + (items (if (list? param-list) param-list (list)))) + (foreign-parse-params-loop items result)))) + +;; ═══════════════════════════════════════════════════════════════ +;; 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. +;; ═══════════════════════════════════════════════════════════════ +(define + foreign-parse-kwargs! + (fn + (spec remaining) + (when + (and + (not (empty? remaining)) + (>= (len remaining) 2) + (keyword? (first remaining))) + (dict-set! + spec + (keyword-name (first remaining)) + (let + ((v (nth remaining 1))) + (if (keyword? v) (keyword-name v) v))) + (foreign-parse-kwargs! spec (rest (rest remaining)))))) + +;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise +(define + foreign-resolve-binding + (fn + (binding-str) + (let + ((parts (split binding-str "."))) + (if + (<= (len parts) 1) + {:method binding-str :object nil} + (let + ((method (last parts)) + (obj (join "." (reverse (rest (reverse parts)))))) + {:method method :object obj}))))) + +;; 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 + foreign-check-args + (fn + (name params args) + (when + (and (not (empty? params)) (< (len args) (len params))) + (error + (str + "foreign " + name + ": expected " + (len params) + " args, got " + (len args)))) + (for-each + (fn + (i) + (let + ((spec (nth params i)) + (val (nth args i)) + (expected (get spec "type"))) + (when + (and + (not (= expected "any")) + (not (value-matches-type? val expected))) + (error + (str + "foreign " + name + ": arg '" + (get spec "name") + "' expected " + expected + ", got " + (type-of val)))))) + (range 0 (min (len params) (len args)))))) + +;; call/cc: capture entire kont as undelimited escape continuation +(define + foreign-build-lambda + (fn + (spec) + (let + ((name (get spec "name")) + (mode + (if + (has-key? spec "returns") + (let + ((r (get spec "returns"))) + (if (= r "promise") "async" "sync")) + "sync"))) + (if + (= mode "async") + (list + (quote fn) + (list (quote &rest) (quote __ffi-args__)) + (list + (quote perform) + (list + (quote foreign-dispatch) + (list (quote quote) name) + (quote __ffi-args__)))) + (list + (quote fn) + (list (quote &rest) (quote __ffi-args__)) + (list + (quote foreign-dispatch) + (list (quote quote) name) + (quote __ffi-args__))))))) + +(define + sf-define-foreign + (fn + (args env) + (let + ((name (if (symbol? (first args)) (symbol-name (first args)) (first args))) + (param-list (nth args 1)) + (spec (dict))) + (dict-set! spec "name" name) + (dict-set! spec "params" (foreign-parse-params param-list)) + (foreign-parse-kwargs! spec (rest (rest args))) + (foreign-register! name spec) + spec))) + +(define + step-sf-define-foreign + (fn + (args env kont) + (let + ((spec (sf-define-foreign args env)) + (name + (if + (symbol? (first args)) + (symbol-name (first args)) + (first args))) + (lambda-expr (foreign-build-lambda spec))) + (make-cek-state + lambda-expr + env + (kont-push (make-define-foreign-frame name spec env) kont))))) + +;; Pattern matching (match form) +(define + foreign-dispatch + (fn + (name args) + (let + ((spec (foreign-lookup name))) + (when + (nil? spec) + (error (str "foreign-dispatch: unknown foreign function '" name "'"))) + (let + ((params (get spec "params")) (binding (get spec "js"))) + (foreign-check-args name (if (nil? params) (list) params) args) + (if + (nil? binding) + (error (str "foreign " name ": no binding for current platform")) + (let + ((resolved (foreign-resolve-binding binding)) + (obj-name (get resolved "object")) + (method (get resolved "method"))) + (if + (primitive? "host-call") + (if + (nil? obj-name) + (apply + (get-primitive "host-call") + (concat (list nil method) args)) + (let + ((obj ((get-primitive "host-global") obj-name))) + (apply + (get-primitive "host-call") + (concat (list obj method) args)))) + (error + (str + "foreign " + name + ": host-call not available on this platform"))))))))) + +;; Condition system special forms +(define + foreign-parse-params-loop + (fn + (items acc) + (if + (empty? items) + acc + (let + ((item (first items)) (rest-items (rest items))) + (if + (and + (not (empty? rest-items)) + (keyword? (first rest-items)) + (= (keyword-name (first rest-items)) "as") + (>= (len rest-items) 2)) + (foreign-parse-params-loop + (rest (rest rest-items)) + (append acc (list {:type (let ((t (nth rest-items 1))) (if (keyword? t) (keyword-name t) (str t))) :name (if (symbol? item) (symbol-name item) (str item))}))) + (foreign-parse-params-loop + rest-items + (append acc (list {:type "any" :name (if (symbol? item) (symbol-name item) (str item))})))))))) + (define step-sf-io (fn @@ -471,17 +711,8 @@ (define *prim-param-types* nil) -;; Macro expansion — expand then re-evaluate the result (define set-prim-param-types! (fn (types) (set! *prim-param-types* types))) -;; ═══════════════════════════════════════════════════════════════ -;; 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 value-matches-type? (fn @@ -579,12 +810,6 @@ (define eval-expr (fn (expr (env :as dict)) nil)) -;; ═══════════════════════════════════════════════════════════════ -;; 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. -;; ═══════════════════════════════════════════════════════════════ (define bind-lambda-params (fn @@ -609,7 +834,6 @@ true)) false)))) -;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise (define call-lambda (fn @@ -636,9 +860,6 @@ (slice params (len args)))) (make-thunk (lambda-body f) local)))) -;; 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 call-component (fn @@ -656,7 +877,6 @@ (env-bind! local "children" children)) (make-thunk (component-body comp) local)))) -;; call/cc: capture entire kont as undelimited escape continuation (define parse-keyword-args (fn @@ -715,7 +935,7 @@ (= (type-of test) "symbol") (or (= (symbol-name test) "else") (= (symbol-name test) ":else")))))) -;; Pattern matching (match form) +;; Scope/provide/context — structured downward data passing (define sf-named-let (fn @@ -763,7 +983,6 @@ ((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits))) (cek-call loop-fn init-vals)))))) -;; Condition system special forms (define sf-lambda (fn @@ -852,6 +1071,18 @@ (range 2 end 1)) result))) +;; ═══════════════════════════════════════════════════════════════ +;; 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 parse-comp-params (fn @@ -898,6 +1129,8 @@ params-expr) (list params has-children param-types)))) +;; Match a list pattern against a form list, handling ellipsis at any position. +;; pi = pattern index, fi = form index. (define sf-defisland (fn @@ -923,6 +1156,8 @@ (env-bind! env (symbol-name name-sym) island) island)))) +;; Find which pattern variable in a template drives an ellipsis. +;; Returns the variable name (string) whose binding is a list, or nil. (define defio-parse-kwargs! (fn @@ -935,6 +1170,8 @@ (dict-set! spec (keyword-name (first remaining)) (nth remaining 1)) (defio-parse-kwargs! spec (rest (rest remaining)))))) +;; Find ALL ellipsis-bound pattern variables in a template. +;; Returns a list of variable name strings. (define sf-defio (fn @@ -946,6 +1183,8 @@ (io-register! name spec) spec))) +;; Instantiate a template with pattern variable bindings. +;; Handles ellipsis repetition and recursive substitution. (define sf-defmacro (fn @@ -962,6 +1201,9 @@ (env-bind! env (symbol-name name-sym) mac) mac)))) +;; 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 parse-macro-params (fn @@ -990,6 +1232,10 @@ params-expr) (list params rest-param)))) +;; 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 qq-expand (fn @@ -1084,6 +1330,10 @@ (slice body 0 (dec (len body)))) (make-thunk (last body) local)))) +;; 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 step-sf-letrec (fn @@ -1102,6 +1352,17 @@ (after (trampoline (eval-expr (nth args 2) env)))) (dynamic-wind-call before body after env)))) +;; 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-scope (fn @@ -1129,6 +1390,7 @@ (scope-pop! name) result)))) +;; Delimited continuations (define sf-provide (fn @@ -1180,7 +1442,7 @@ (slice raw-args (len (macro-params mac))))) (trampoline (eval-expr (macro-body mac) local))))))) -;; Scope/provide/context — structured downward data passing +;; Signal dereferencing with reactive dependency tracking (define cek-step-loop (fn @@ -1190,6 +1452,13 @@ state (cek-step-loop (cek-step state))))) +;; ═══════════════════════════════════════════════════════════════ +;; 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 cek-run (fn @@ -1201,6 +1470,7 @@ (error "IO suspension in non-IO context") (cek-value final))))) +;; Reactive signal tracking — captures dependency continuation for re-render (define cek-resume (fn @@ -1221,17 +1491,12 @@ (step-continue state)))) ;; ═══════════════════════════════════════════════════════════════ -;; R7RS syntax-rules / define-syntax +;; Part 9: Higher-Order Form Machinery ;; -;; 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). +;; 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-*. ;; ═══════════════════════════════════════════════════════════════ - -;; 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 (fn @@ -1288,8 +1553,6 @@ (step-eval-list expr env kont)) :else (make-cek-value expr env kont))))) -;; Match a list pattern against a form list, handling ellipsis at any position. -;; pi = pattern index, fi = form index. (define step-sf-raise (fn @@ -1299,8 +1562,6 @@ env (kont-push (make-raise-eval-frame env false) kont)))) -;; Find which pattern variable in a template drives an ellipsis. -;; Returns the variable name (string) whose binding is a list, or nil. (define step-sf-guard (fn @@ -1374,8 +1635,6 @@ env kont)))) -;; Find ALL ellipsis-bound pattern variables in a template. -;; Returns a list of variable name strings. (define step-sf-callcc (fn @@ -1385,8 +1644,6 @@ env (kont-push (make-callcc-frame env) kont)))) -;; Instantiate a template with pattern variable bindings. -;; Handles ellipsis repetition and recursive substitution. (define step-sf-case (fn @@ -1396,9 +1653,6 @@ env (kont-push (make-case-frame nil (rest args) env) kont)))) -;; 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 step-sf-let-match (fn @@ -1412,10 +1666,6 @@ env kont)))) -;; 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 step-eval-list (fn @@ -1456,6 +1706,7 @@ ("defisland" (make-cek-value (sf-defisland args env) env kont)) ("defmacro" (make-cek-value (sf-defmacro args env) env kont)) ("defio" (make-cek-value (sf-defio args env) env kont)) + ("define-foreign" (step-sf-define-foreign args env kont)) ("io" (step-sf-io args env kont)) ("begin" (step-sf-begin args env kont)) ("do" @@ -1598,10 +1849,6 @@ (cons {:subscribers (list) :env (get frame "env") :value (get frame "value") :type "provide" :remaining (list) :name (get frame "name")} rest-frames) rest-frames))))) -;; 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 fire-provide-subscribers (fn @@ -1640,22 +1887,18 @@ subs) (for-each (fn (sub) (cek-call sub (list nil))) subs)))))) -;; 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 batch-begin! (fn () (set! *provide-batch-depth* (+ *provide-batch-depth* 1)))) -;; Delimited continuations +;; ═══════════════════════════════════════════════════════════════ +;; 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 batch-end! (fn @@ -1668,6 +1911,9 @@ (set! *provide-batch-queue* (list)) (for-each (fn (sub) (cek-call sub (list nil))) queue))))) +;; 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-bind (fn @@ -1680,7 +1926,6 @@ env (kont-push (make-bind-frame body env prev) kont))))) -;; Signal dereferencing with reactive dependency tracking (define step-sf-parameterize (fn @@ -1700,11 +1945,11 @@ kont))))))) ;; ═══════════════════════════════════════════════════════════════ -;; Part 8: Call Dispatch +;; Part 11: Entry Points ;; -;; 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. +;; eval-expr-cek / trampoline-cek: CEK evaluation entry points. +;; eval-expr / trampoline: top-level bindings that override the +;; forward declarations from Part 5. ;; ═══════════════════════════════════════════════════════════════ (define syntax-rules-match @@ -1726,7 +1971,6 @@ (syntax-rules-match-list pattern 0 form 0 literals) :else (if (= pattern form) (dict) nil)))) -;; Reactive signal tracking — captures dependency continuation for re-render (define syntax-rules-match-list (fn @@ -1828,13 +2072,6 @@ template) :else nil))) -;; ═══════════════════════════════════════════════════════════════ -;; 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 syntax-rules-find-all-vars (fn @@ -2076,14 +2313,6 @@ (define *protocol-registry* (dict)) -;; ═══════════════════════════════════════════════════════════════ -;; 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 sf-define-record-type (fn @@ -2120,9 +2349,6 @@ field-specs) nil)))))) -;; 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 sf-define-protocol (fn @@ -2239,13 +2465,6 @@ (list "match checks nil but has no non-nil pattern")))) warnings))) -;; ═══════════════════════════════════════════════════════════════ -;; 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 sf-implement (fn @@ -3293,6 +3512,14 @@ (dict-set! effect-anns name effect-names) (env-bind! fenv "*effect-annotations*" effect-anns))) (make-cek-value value fenv rest-k))) + ("define-foreign" + (let + ((name (get frame "name")) (fenv (get frame "env"))) + (when + (and (lambda? value) (nil? (lambda-name value))) + (set-lambda-name! value name)) + (env-bind! fenv name value) + (make-cek-value value fenv rest-k))) ("set" (let ((name (get frame "name")) (fenv (get frame "env"))) diff --git a/spec/tests/test-foreign.sx b/spec/tests/test-foreign.sx new file mode 100644 index 00000000..d1b666d6 --- /dev/null +++ b/spec/tests/test-foreign.sx @@ -0,0 +1,179 @@ +;; FFI tests — define-foreign, *foreign-registry*, foreign-dispatch + +(defsuite + "foreign-registry-basic" + (deftest + "define-foreign registers in *foreign-registry*" + (define-foreign my-abs (x :as number) :returns :number :js "Math.abs") + (assert (foreign-registered? "my-abs"))) + (deftest + "foreign-lookup returns spec dict" + (define-foreign my-floor (x :as number) :returns :number :js "Math.floor") + (let + ((spec (foreign-lookup "my-floor"))) + (assert= (get spec "name") "my-floor") + (assert= (get spec "js") "Math.floor") + (assert= (get spec "returns") "number"))) + (deftest + "foreign-names includes registered names" + (define-foreign my-ceil (x :as number) :returns :number :js "Math.ceil") + (assert (contains? (foreign-names) "my-ceil"))) + (deftest + "define-foreign creates callable lambda" + (define-foreign my-round (x :as number) :returns :number :js "Math.round") + (assert (lambda? my-round))) + (deftest + "multiple define-foreign coexist" + (define-foreign ff-a () :js "Date.now") + (define-foreign ff-b (s :as string) :js "parseInt") + (assert (foreign-registered? "ff-a")) + (assert (foreign-registered? "ff-b")))) + +(defsuite + "foreign-param-parsing" + (deftest + "single param with type" + (define-foreign fp-one (url :as string) :js "encodeURI") + (let + ((spec (foreign-lookup "fp-one"))) + (let + ((params (get spec "params"))) + (assert= (len params) 1) + (assert= (get (first params) "name") "url") + (assert= (get (first params) "type") "string")))) + (deftest + "multiple params with types" + (define-foreign fp-two (base :as string radix :as number) :js "parseInt") + (let + ((spec (foreign-lookup "fp-two"))) + (let + ((params (get spec "params"))) + (assert= (len params) 2) + (assert= (get (first params) "name") "base") + (assert= (get (first params) "type") "string") + (assert= (get (nth params 1) "name") "radix") + (assert= (get (nth params 1) "type") "number")))) + (deftest + "no params" + (define-foreign fp-none () :js "Date.now") + (let + ((spec (foreign-lookup "fp-none"))) + (assert= (len (get spec "params")) 0))) + (deftest + "param without :as defaults to any" + (define-foreign fp-any (x) :js "String") + (let + ((spec (foreign-lookup "fp-any"))) + (let + ((params (get spec "params"))) + (assert= (get (first params) "type") "any")))) + (deftest + "callback param type" + (define-foreign fp-cb (handler :as callback) :js "setTimeout") + (let + ((spec (foreign-lookup "fp-cb"))) + (assert= (get (first (get spec "params")) "type") "callback")))) + +(defsuite + "foreign-binding-resolution" + (deftest + "dotted binding splits into object + method" + (let + ((resolved (foreign-resolve-binding "localStorage.getItem"))) + (assert= (get resolved "object") "localStorage") + (assert= (get resolved "method") "getItem"))) + (deftest + "simple binding has nil object" + (let + ((resolved (foreign-resolve-binding "parseInt"))) + (assert= (get resolved "object") nil) + (assert= (get resolved "method") "parseInt"))) + (deftest + "deep dotted binding preserves object path" + (let + ((resolved (foreign-resolve-binding "window.navigator.language"))) + (assert= (get resolved "object") "window.navigator") + (assert= (get resolved "method") "language"))) + (deftest + "single segment is method only" + (let + ((resolved (foreign-resolve-binding "alert"))) + (assert= (get resolved "object") nil) + (assert= (get resolved "method") "alert")))) + +(defsuite + "foreign-kwargs" + (deftest + "returns keyword parsed correctly" + (define-foreign fk-ret (x :as number) :returns :number :js "Math.abs") + (assert= (get (foreign-lookup "fk-ret") "returns") "number")) + (deftest + "doc keyword stored" + (define-foreign fk-doc () :js "Date.now" :doc "Get current timestamp") + (assert= (get (foreign-lookup "fk-doc") "doc") "Get current timestamp")) + (deftest + "capability keyword stored" + (define-foreign + fk-cap + (url :as string) + :returns :promise + :js "window.fetch" + :capability :network) + (assert= (get (foreign-lookup "fk-cap") "capability") "network")) + (deftest + "promise return type" + (define-foreign + fk-async + (url :as string) + :returns :promise + :js "window.fetch") + (assert= (get (foreign-lookup "fk-async") "returns") "promise"))) + +(defsuite + "foreign-build-lambda" + (deftest + "sync foreign builds non-perform lambda" + (define-foreign fbl-sync (x :as number) :returns :number :js "Math.abs") + (let + ((spec (foreign-lookup "fbl-sync"))) + (let + ((expr (foreign-build-lambda spec))) + (assert (list? expr)) + (assert= (symbol-name (first expr)) "fn")))) + (deftest + "async foreign builds perform-wrapping lambda" + (define-foreign + fbl-async + (url :as string) + :returns :promise + :js "window.fetch") + (let + ((spec (foreign-lookup "fbl-async"))) + (let + ((expr (foreign-build-lambda spec))) + (assert (list? expr)) + (let + ((body (nth expr 2))) + (assert= (symbol-name (first body)) "perform")))))) + +(defsuite + "foreign-type-checking" + (deftest + "foreign-check-args accepts correct types" + (foreign-check-args "test" (list {:type "number" :name "x"}) (list 42)) + (assert true)) + (deftest + "foreign-check-args rejects wrong type" + (let + ((err (guard (e (#t (error-message e))) (foreign-check-args "test" (list {:type "number" :name "x"}) (list "not-a-number")) nil))) + (assert (contains? err "expected number")))) + (deftest + "foreign-check-args accepts any type" + (foreign-check-args "test" (list {:type "any" :name "x"}) (list "hello")) + (foreign-check-args "test" (list {:type "any" :name "x"}) (list 42)) + (assert true)) + (deftest + "foreign-check-args rejects too few args" + (let + ((err (guard (e (#t (error-message e))) (foreign-check-args "test" (list {:type "number" :name "x"} {:type "number" :name "y"}) (list 1)) nil))) + (assert (contains? err "expected 2 args"))))) \ No newline at end of file