giles
2f3e727a6f
When the VM or CEK hits an undefined symbol, it checks a symbol→library index (built from manifest exports at boot), loads the library that exports it, and returns the value. Execution continues as if the module was always loaded. No import statements, no load-library! calls, no Suspense boundaries — just call the function. This is the same mechanism as IO suspension for data fetching. The programmer doesn't distinguish between calling a local function and calling one that needs its module fetched first. The runtime treats code as just another resource. Implementation: - _symbol_resolve_hook in sx_types.ml — called by env_get_id (CEK path) and vm_global_get (VM path) when a symbol isn't found - Symbol→library index built from manifest exports in sx-platform.js - __resolve-symbol native calls __sxLoadLibrary, module loads, symbol appears in globals, execution resumes - compile-modules.js extracts export lists into module-manifest.json - Playground page demonstrates: (freeze-scope) triggers freeze.sxbc download transparently on first use 2650/2650 tests pass. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
868 lines
137 KiB
OCaml
868 lines
137 KiB
OCaml
(* sx_ref.ml — Auto-generated from SX spec by hosts/ocaml/bootstrap.py *)
|
|
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap.py *)
|
|
|
|
[@@@warning "-26-27"]
|
|
|
|
open Sx_types
|
|
open Sx_runtime
|
|
|
|
(* Trampoline — forward ref, resolved after eval_expr is defined. *)
|
|
let trampoline_fn : (value -> value) ref = ref (fun v -> v)
|
|
let trampoline v = !trampoline_fn v
|
|
|
|
|
|
|
|
(* === Mutable globals — backing refs for transpiler's !_ref / _ref := === *)
|
|
let _strict_ref = ref (Bool false)
|
|
let _prim_param_types_ref = ref Nil
|
|
let _last_error_kont_ref = ref Nil
|
|
let _protocol_registry_ = Dict (Hashtbl.create 0)
|
|
|
|
|
|
|
|
(* === Transpiled from evaluator (frames + eval + CEK) === *)
|
|
|
|
(* make-cek-state *)
|
|
let rec make_cek_state control env kont =
|
|
(CekState { cs_control = control; cs_env = env; cs_kont = kont; cs_phase = "eval"; cs_value = Nil })
|
|
|
|
(* make-cek-value *)
|
|
and make_cek_value value env kont =
|
|
(CekState { cs_control = Nil; cs_env = env; cs_kont = kont; cs_phase = "continue"; cs_value = value })
|
|
|
|
(* make-cek-suspended *)
|
|
and make_cek_suspended request env kont =
|
|
(let _d = Hashtbl.create 4 in Hashtbl.replace _d "env" env; Hashtbl.replace _d "kont" kont; Hashtbl.replace _d "phase" (String "io-suspended"); Hashtbl.replace _d "request" request; Dict _d)
|
|
|
|
(* cek-terminal? *)
|
|
and cek_terminal_p state =
|
|
(let _and = (prim_call "=" [(get (state) ((String "phase"))); (String "continue")]) in if not (sx_truthy _and) then _and else (empty_p ((get (state) ((String "kont"))))))
|
|
|
|
(* cek-suspended? *)
|
|
and cek_suspended_p state =
|
|
(prim_call "=" [(get (state) ((String "phase"))); (String "io-suspended")])
|
|
|
|
(* cek-control *)
|
|
and cek_control s =
|
|
(get (s) ((String "control")))
|
|
|
|
(* cek-env *)
|
|
and cek_env s =
|
|
(get (s) ((String "env")))
|
|
|
|
(* cek-kont *)
|
|
and cek_kont s =
|
|
(get (s) ((String "kont")))
|
|
|
|
(* cek-phase *)
|
|
and cek_phase s =
|
|
(get (s) ((String "phase")))
|
|
|
|
(* cek-io-request *)
|
|
and cek_io_request s =
|
|
(get (s) ((String "request")))
|
|
|
|
(* cek-value *)
|
|
and cek_value s =
|
|
(get (s) ((String "value")))
|
|
|
|
(* make-if-frame *)
|
|
and make_if_frame then_expr else_expr env =
|
|
(CekFrame { cf_type = "if"; cf_env = env; cf_name = else_expr; cf_body = then_expr; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-when-frame *)
|
|
and make_when_frame body_exprs env =
|
|
(CekFrame { cf_type = "when"; cf_env = env; cf_name = Nil; cf_body = body_exprs; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-begin-frame *)
|
|
and make_begin_frame remaining env =
|
|
(CekFrame { cf_type = "begin"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-let-frame *)
|
|
and make_let_frame name remaining body local =
|
|
(CekFrame { cf_type = "let"; cf_env = local; cf_name = name; cf_body = body; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-define-frame *)
|
|
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-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 })
|
|
|
|
(* make-arg-frame *)
|
|
and make_arg_frame f evaled remaining env raw_args head_name =
|
|
(CekFrame { cf_type = "arg"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = evaled; cf_results = raw_args; cf_extra = (let _or = head_name in if sx_truthy _or then _or else Nil); cf_extra2 = Nil })
|
|
|
|
(* make-call-frame *)
|
|
and make_call_frame f args env =
|
|
(CekFrame { cf_type = "call"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = f; cf_args = args; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-cond-frame *)
|
|
and make_cond_frame remaining env scheme_p =
|
|
(CekFrame { cf_type = "cond"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = scheme_p; cf_extra2 = Nil })
|
|
|
|
(* make-cond-arrow-frame *)
|
|
and make_cond_arrow_frame test_value env =
|
|
(CekFrame { cf_type = "cond-arrow"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = test_value; cf_extra2 = Nil })
|
|
|
|
(* make-case-frame *)
|
|
and make_case_frame match_val remaining env =
|
|
(CekFrame { cf_type = "case"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = match_val; cf_extra2 = Nil })
|
|
|
|
(* make-thread-frame *)
|
|
and make_thread_frame remaining env mode name =
|
|
(CekFrame { cf_type = "thread"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = mode; cf_extra2 = Nil })
|
|
|
|
(* thread-insert-arg *)
|
|
and thread_insert_arg form value fenv =
|
|
(if sx_truthy ((prim_call "=" [(type_of (form)); (String "list")])) then (eval_expr ((cons ((first (form))) ((cons ((List [(Symbol "quote"); value])) ((rest (form))))))) (fenv)) else (eval_expr ((List [form; (List [(Symbol "quote"); value])])) (fenv)))
|
|
|
|
(* thread-insert-arg-last *)
|
|
and thread_insert_arg_last form value fenv =
|
|
(if sx_truthy ((prim_call "=" [(type_of (form)); (String "list")])) then (eval_expr ((prim_call "append" [form; (List [(List [(Symbol "quote"); value])])])) (fenv)) else (eval_expr ((List [form; (List [(Symbol "quote"); value])])) (fenv)))
|
|
|
|
(* make-map-frame *)
|
|
and make_map_frame f remaining results env =
|
|
(CekFrame { cf_type = "map"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = results; cf_extra = (Bool false); cf_extra2 = Nil })
|
|
|
|
(* make-map-indexed-frame *)
|
|
and make_map_indexed_frame f remaining results env =
|
|
(CekFrame { cf_type = "map"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = results; cf_extra = (Bool true); cf_extra2 = Nil })
|
|
|
|
(* make-multi-map-frame *)
|
|
and make_multi_map_frame f remaining_lists results env =
|
|
(CekFrame { cf_type = "multi-map"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining_lists; cf_f = f; cf_args = Nil; cf_results = results; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-filter-frame *)
|
|
and make_filter_frame f remaining results current_item env =
|
|
(CekFrame { cf_type = "filter"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = results; cf_extra = current_item; cf_extra2 = Nil })
|
|
|
|
(* make-reduce-frame *)
|
|
and make_reduce_frame f remaining env =
|
|
(CekFrame { cf_type = "reduce"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-for-each-frame *)
|
|
and make_for_each_frame f remaining env =
|
|
(CekFrame { cf_type = "for-each"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-some-frame *)
|
|
and make_some_frame f remaining env =
|
|
(CekFrame { cf_type = "some"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-every-frame *)
|
|
and make_every_frame f remaining env =
|
|
(CekFrame { cf_type = "every"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = f; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-scope-frame *)
|
|
and make_scope_frame name remaining env =
|
|
(CekFrame { cf_type = "scope"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-provide-frame *)
|
|
and make_provide_frame name value remaining env =
|
|
(CekFrame { cf_type = "provide"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = value; cf_extra2 = Nil })
|
|
|
|
(* make-scope-acc-frame *)
|
|
and make_scope_acc_frame name value remaining env =
|
|
(CekFrame { cf_type = "scope-acc"; cf_env = env; cf_name = name; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = (let _or = value in if sx_truthy _or then _or else Nil); cf_extra2 = (List []) })
|
|
|
|
(* make-reset-frame *)
|
|
and make_reset_frame env =
|
|
(CekFrame { cf_type = "reset"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-dict-frame *)
|
|
and make_dict_frame remaining results env =
|
|
(CekFrame { cf_type = "dict"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = results; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-and-frame *)
|
|
and make_and_frame remaining env =
|
|
(CekFrame { cf_type = "and"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-or-frame *)
|
|
and make_or_frame remaining env =
|
|
(CekFrame { cf_type = "or"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-dynamic-wind-frame *)
|
|
and make_dynamic_wind_frame phase body_thunk after_thunk env =
|
|
(CekFrame { cf_type = "dynamic-wind"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = phase; cf_extra2 = Nil })
|
|
|
|
(* make-reactive-reset-frame *)
|
|
and make_reactive_reset_frame env update_fn first_render_p =
|
|
(CekFrame { cf_type = "reactive-reset"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = update_fn; cf_extra2 = first_render_p })
|
|
|
|
(* make-callcc-frame *)
|
|
and make_callcc_frame env =
|
|
(CekFrame { cf_type = "callcc"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-deref-frame *)
|
|
and make_deref_frame env =
|
|
(CekFrame { cf_type = "deref"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-ho-setup-frame *)
|
|
and make_ho_setup_frame ho_type remaining_args evaled_args env =
|
|
(CekFrame { cf_type = "ho-setup"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining_args; cf_f = Nil; cf_args = evaled_args; cf_results = Nil; cf_extra = ho_type; cf_extra2 = Nil })
|
|
|
|
(* make-comp-trace-frame *)
|
|
and make_comp_trace_frame name file =
|
|
(CekFrame { cf_type = "comp-trace"; cf_env = file; cf_name = name; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* kont-collect-comp-trace *)
|
|
and kont_collect_comp_trace kont =
|
|
(if sx_truthy ((empty_p (kont))) then (List []) else (let frame = (first (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "comp-trace")])) then (cons ((let _d = Hashtbl.create 2 in Hashtbl.replace _d "file" (get (frame) ((String "file"))); Hashtbl.replace _d "name" (get (frame) ((String "name"))); Dict _d)) ((kont_collect_comp_trace ((rest (kont)))))) else (kont_collect_comp_trace ((rest (kont)))))))
|
|
|
|
(* make-handler-frame *)
|
|
and make_handler_frame handlers remaining env =
|
|
(CekFrame { cf_type = "handler"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = handlers; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-restart-frame *)
|
|
and make_restart_frame restarts remaining env =
|
|
(CekFrame { cf_type = "restart"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining; cf_f = restarts; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-signal-return-frame *)
|
|
and make_signal_return_frame env saved_kont =
|
|
(CekFrame { cf_type = "signal-return"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = saved_kont; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-raise-eval-frame *)
|
|
and make_raise_eval_frame env continuable_p =
|
|
(CekFrame { cf_type = "raise-eval"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = continuable_p; cf_extra2 = Nil })
|
|
|
|
(* make-raise-guard-frame *)
|
|
and make_raise_guard_frame env saved_kont =
|
|
(CekFrame { cf_type = "raise-guard"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = saved_kont; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-perform-frame *)
|
|
and make_perform_frame env =
|
|
(CekFrame { cf_type = "perform"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-vm-resume-frame *)
|
|
and make_vm_resume_frame resume_fn env =
|
|
(CekFrame { cf_type = "vm-resume"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = resume_fn; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-import-frame *)
|
|
and make_import_frame import_set remaining_sets env =
|
|
(CekFrame { cf_type = "import"; cf_env = env; cf_name = Nil; cf_body = Nil; cf_remaining = remaining_sets; cf_f = Nil; cf_args = import_set; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* make-parameterize-frame *)
|
|
and make_parameterize_frame remaining current_param results body env =
|
|
(CekFrame { cf_type = "parameterize"; cf_env = env; cf_name = Nil; cf_body = body; cf_remaining = remaining; cf_f = current_param; cf_args = Nil; cf_results = results; cf_extra = Nil; cf_extra2 = Nil })
|
|
|
|
(* find-matching-handler *)
|
|
and find_matching_handler handlers condition =
|
|
(if sx_truthy ((empty_p (handlers))) then Nil else (let pair = (first (handlers)) in (let pred = (first (pair)) in let handler_fn = (nth (pair) ((Number 1.0))) in (if sx_truthy ((cek_call (pred) ((List [condition])))) then handler_fn else (find_matching_handler ((rest (handlers))) (condition))))))
|
|
|
|
(* kont-find-handler *)
|
|
and kont_find_handler kont condition =
|
|
(if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "handler")])) then (let match' = (find_matching_handler ((get (frame) ((String "f")))) (condition)) in (if sx_truthy ((is_nil (match'))) then (kont_find_handler ((rest (kont))) (condition)) else match')) else (kont_find_handler ((rest (kont))) (condition)))))
|
|
|
|
(* find-named-restart *)
|
|
and find_named_restart restarts name =
|
|
(if sx_truthy ((empty_p (restarts))) then Nil else (let entry = (first (restarts)) in (if sx_truthy ((prim_call "=" [(first (entry)); name])) then entry else (find_named_restart ((rest (restarts))) (name)))))
|
|
|
|
(* kont-find-restart *)
|
|
and kont_find_restart kont name =
|
|
(if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "restart")])) then (let match' = (find_named_restart ((get (frame) ((String "f")))) (name)) in (if sx_truthy ((is_nil (match'))) then (kont_find_restart ((rest (kont))) (name)) else (List [match'; frame; (rest (kont))]))) else (kont_find_restart ((rest (kont))) (name)))))
|
|
|
|
(* frame-type *)
|
|
and frame_type f =
|
|
(get (f) ((String "type")))
|
|
|
|
(* kont-push *)
|
|
and kont_push frame kont =
|
|
(cons (frame) (kont))
|
|
|
|
(* kont-top *)
|
|
and kont_top kont =
|
|
(first (kont))
|
|
|
|
(* kont-pop *)
|
|
and kont_pop kont =
|
|
(rest (kont))
|
|
|
|
(* kont-empty? *)
|
|
and kont_empty_p kont =
|
|
(empty_p (kont))
|
|
|
|
(* kont-capture-to-reset *)
|
|
and kont_capture_to_reset kont =
|
|
(let rec scan = (fun k captured -> (if sx_truthy ((empty_p (k))) then (raise (Eval_error (value_to_str (String "shift without enclosing reset")))) else (let frame = (first (k)) in (if sx_truthy ((let _or = (prim_call "=" [(frame_type (frame)); (String "reset")]) in if sx_truthy _or then _or else (prim_call "=" [(frame_type (frame)); (String "reactive-reset")]))) then (List [captured; (rest (k))]) else (scan ((rest (k))) ((prim_call "append" [captured; (List [frame])]))))))) in (scan (kont) ((List []))))
|
|
|
|
(* kont-push-provides *)
|
|
and kont_push_provides pairs env kont =
|
|
(if sx_truthy ((empty_p (pairs))) then kont else (let pair = (first (pairs)) in (kont_push_provides ((rest (pairs))) (env) ((cons ((make_provide_frame ((first (pair))) ((nth (pair) ((Number 1.0)))) ((List [])) (env))) (kont))))))
|
|
|
|
(* kont-find-provide *)
|
|
and kont_find_provide kont name =
|
|
(if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((let _and = (prim_call "=" [(frame_type (frame)); (String "provide")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(get (frame) ((String "name"))); name]))) then frame else (kont_find_provide ((rest (kont))) (name)))))
|
|
|
|
(* kont-find-scope-acc *)
|
|
and kont_find_scope_acc kont name =
|
|
(if sx_truthy ((empty_p (kont))) then Nil else (let frame = (first (kont)) in (if sx_truthy ((let _and = (prim_call "=" [(frame_type (frame)); (String "scope-acc")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(get (frame) ((String "name"))); name]))) then frame else (kont_find_scope_acc ((rest (kont))) (name)))))
|
|
|
|
(* has-reactive-reset-frame? *)
|
|
and has_reactive_reset_frame_p kont =
|
|
(if sx_truthy ((empty_p (kont))) then (Bool false) else (if sx_truthy ((prim_call "=" [(frame_type ((first (kont)))); (String "reactive-reset")])) then (Bool true) else (has_reactive_reset_frame_p ((rest (kont))))))
|
|
|
|
(* kont-capture-to-reactive-reset *)
|
|
and kont_capture_to_reactive_reset kont =
|
|
(let rec scan = (fun k captured -> (if sx_truthy ((empty_p (k))) then (raise (Eval_error (value_to_str (String "reactive deref without enclosing reactive-reset")))) else (let frame = (first (k)) in (if sx_truthy ((prim_call "=" [(frame_type (frame)); (String "reactive-reset")])) then (List [captured; frame; (rest (k))]) else (scan ((rest (k))) ((prim_call "append" [captured; (List [frame])]))))))) in (scan (kont) ((List []))))
|
|
|
|
(* *custom-special-forms* *)
|
|
and custom_special_forms =
|
|
(Dict (Hashtbl.create 0))
|
|
|
|
(* register-special-form! *)
|
|
and register_special_form name handler =
|
|
(sx_dict_set_b custom_special_forms name handler)
|
|
|
|
(* *render-check* *)
|
|
and render_check =
|
|
Nil
|
|
|
|
(* *render-fn* *)
|
|
and render_fn =
|
|
Nil
|
|
|
|
(* *library-registry* *)
|
|
and _library_registry_ =
|
|
(Dict (Hashtbl.create 0))
|
|
|
|
(* library-name-key *)
|
|
and library_name_key spec =
|
|
(prim_call "join" [(String "."); (List (List.map (fun s -> (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s])))) (sx_to_list spec)))])
|
|
|
|
(* library-loaded? *)
|
|
and library_loaded_p spec =
|
|
(prim_call "has-key?" [_library_registry_; (library_name_key (spec))])
|
|
|
|
(* library-exports *)
|
|
and library_exports spec =
|
|
(get ((get (_library_registry_) ((library_name_key (spec))))) ((String "exports")))
|
|
|
|
(* register-library *)
|
|
and register_library spec exports =
|
|
(sx_dict_set_b _library_registry_ (library_name_key (spec)) (let _d = Hashtbl.create 1 in Hashtbl.replace _d "exports" exports; Dict _d))
|
|
|
|
(* *io-registry* *)
|
|
and _io_registry_ =
|
|
(Dict (Hashtbl.create 0))
|
|
|
|
(* io-register! *)
|
|
and io_register_b name spec =
|
|
(sx_dict_set_b _io_registry_ name spec)
|
|
|
|
(* io-registered? *)
|
|
and io_registered_p name =
|
|
(prim_call "has-key?" [_io_registry_; name])
|
|
|
|
(* io-lookup *)
|
|
and io_lookup name =
|
|
(get (_io_registry_) (name))
|
|
|
|
(* io-names *)
|
|
and io_names () =
|
|
(prim_call "keys" [_io_registry_])
|
|
|
|
(* 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_ =
|
|
!_strict_ref
|
|
|
|
(* set-strict! *)
|
|
and set_strict_b val' =
|
|
let _strict_ = ref Nil in (_strict_ref := val'; Nil)
|
|
|
|
(* *prim-param-types* *)
|
|
and _prim_param_types_ =
|
|
!_prim_param_types_ref
|
|
|
|
(* set-prim-param-types! *)
|
|
and set_prim_param_types_b types =
|
|
let _prim_param_types_ = ref Nil in (_prim_param_types_ref := types; Nil)
|
|
|
|
(* value-matches-type? *)
|
|
and value_matches_type_p val' expected_type =
|
|
(let _match_val = expected_type in (if sx_truthy ((prim_call "=" [_match_val; (String "any")])) then (Bool true) else (if sx_truthy ((prim_call "=" [_match_val; (String "number")])) then (number_p (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "string")])) then (string_p (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "boolean")])) then (boolean_p (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "nil")])) then (is_nil (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "list")])) then (list_p (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "dict")])) then (dict_p (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "lambda")])) then (is_lambda (val')) else (if sx_truthy ((prim_call "=" [_match_val; (String "symbol")])) then (prim_call "=" [(type_of (val')); (String "symbol")]) else (if sx_truthy ((prim_call "=" [_match_val; (String "keyword")])) then (prim_call "=" [(type_of (val')); (String "keyword")]) else (if sx_truthy ((let _and = (string_p (expected_type)) in if not (sx_truthy _and) then _and else (prim_call "ends-with?" [expected_type; (String "?")]))) then (let _or = (is_nil (val')) in if sx_truthy _or then _or else (value_matches_type_p (val') ((prim_call "slice" [expected_type; (Number 0.0); (prim_call "-" [(prim_call "string-length" [expected_type]); (Number 1.0)])])))) else (Bool true)))))))))))))
|
|
|
|
(* strict-check-args *)
|
|
and strict_check_args name args =
|
|
(if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else !_prim_param_types_ref)) then (let spec = (get (!_prim_param_types_ref) (name)) in (if sx_truthy (spec) then (let positional = (get (spec) ((String "positional"))) in let rest_type = (get (spec) ((String "rest-type"))) in (let () = ignore ((if sx_truthy (positional) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let param = (nth (pair) ((Number 1.0))) in let p_name = (first (param)) in let p_type = (nth (param) ((Number 1.0))) in (if sx_truthy ((prim_call "<" [idx; (len (args))])) then (let val' = (nth (args) (idx)) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (p_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); p_type; (String " for param "); p_name; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [i; p])) (sx_to_list positional)))); Nil) else Nil)) in (if sx_truthy ((let _and = rest_type in if not (sx_truthy _and) then _and else (prim_call ">" [(len (args)); (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let val' = (nth (pair) ((Number 1.0))) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (rest_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); rest_type; (String " for rest arg "); idx; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)))) (sx_to_list (List (List.mapi (fun i v -> let i = Number (float_of_int i) in (List [i; v])) (sx_to_list (prim_call "slice" [args; (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))))); Nil) else Nil))) else Nil)) else Nil)
|
|
|
|
(* bind-lambda-params *)
|
|
and bind_lambda_params params args local =
|
|
(let rest_idx = (prim_call "index-of" [params; (String "&rest")]) in (if sx_truthy ((let _and = (number_p (rest_idx)) in if not (sx_truthy _and) then _and else (prim_call "<" [rest_idx; (len (params))]))) then (let positional = (prim_call "slice" [params; (Number 0.0); rest_idx]) in let rest_name = (nth (params) ((prim_call "+" [rest_idx; (Number 1.0)]))) in (let () = ignore ((for_each_indexed ((NativeFn ("\206\187", fun _args -> match _args with [i; p] -> (fun i p -> (env_bind local (sx_to_string p) (if sx_truthy ((prim_call "<" [i; (len (args))])) then (nth (args) (i)) else Nil))) i p | _ -> Nil))) (positional))) in (let () = ignore ((env_bind local (sx_to_string rest_name) (if sx_truthy ((prim_call ">" [(len (args)); rest_idx])) then (prim_call "slice" [args; rest_idx]) else (List [])))) in (Bool true)))) else (Bool false)))
|
|
|
|
(* call-lambda *)
|
|
and call_lambda f args caller_env =
|
|
(let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (caller_env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (make_thunk ((lambda_body (f))) (local))))
|
|
|
|
(* call-component *)
|
|
and call_component comp raw_args env =
|
|
(let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (comp))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (comp))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (comp))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_thunk ((component_body (comp))) (local)))))
|
|
|
|
(* parse-keyword-args *)
|
|
and parse_keyword_args raw_args env =
|
|
(let kwargs = (Dict (Hashtbl.create 0)) in let children = ref ((List [])) in let i = (Number 0.0) in (let () = ignore ((List.fold_left (fun state arg -> (let idx = (get (state) ((String "i"))) in let skip = (get (state) ((String "skip"))) in (if sx_truthy (skip) then (prim_call "assoc" [state; (String "skip"); (Bool false); (String "i"); (prim_call "inc" [idx])]) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (arg)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "<" [(prim_call "inc" [idx]); (len (raw_args))]))) then (let () = ignore ((sx_dict_set_b kwargs (keyword_name (arg)) (trampoline ((eval_expr ((nth (raw_args) ((prim_call "inc" [idx])))) (env)))))) in (prim_call "assoc" [state; (String "skip"); (Bool true); (String "i"); (prim_call "inc" [idx])])) else (let () = ignore ((children := sx_append_b !children (trampoline ((eval_expr (arg) (env)))); Nil)) in (prim_call "assoc" [state; (String "i"); (prim_call "inc" [idx])])))))) (let _d = Hashtbl.create 2 in Hashtbl.replace _d (value_to_str (String "i")) (Number 0.0); Hashtbl.replace _d (value_to_str (String "skip")) (Bool false); Dict _d) (sx_to_list raw_args))) in (List [kwargs; !children])))
|
|
|
|
(* cond-scheme? *)
|
|
and cond_scheme_p clauses =
|
|
(Bool (List.for_all (fun c -> sx_truthy ((let _and = (prim_call "=" [(type_of (c)); (String "list")]) in if not (sx_truthy _and) then _and else (let _or = (prim_call "=" [(len (c)); (Number 2.0)]) in if sx_truthy _or then _or else (let _and = (prim_call "=" [(len (c)); (Number 3.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (c) ((Number 1.0))))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (c) ((Number 1.0))))); (String "=>")]))))))) (sx_to_list clauses)))
|
|
|
|
(* is-else-clause? *)
|
|
and is_else_clause test =
|
|
(let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (let _and = (prim_call "=" [(type_of (test)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _or = (prim_call "=" [(symbol_name (test)); (String "else")]) in if sx_truthy _or then _or else (prim_call "=" [(symbol_name (test)); (String ":else")]))))
|
|
|
|
(* sf-named-let *)
|
|
and sf_named_let args env =
|
|
(let loop_name = (symbol_name ((first (args)))) in let bindings = (nth (args) ((Number 1.0))) in let body = (prim_call "slice" [args; (Number 2.0)]) in let params = ref ((List [])) in let inits = ref ((List [])) in (let () = ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (List.iter (fun binding -> ignore ((let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))); Nil)) in (inits := sx_append_b !inits (nth (binding) ((Number 1.0))); Nil)))) (sx_to_list bindings); Nil) else (List.fold_left (fun _acc pair_idx -> (let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))); (String "symbol")])) then (symbol_name ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))) else (nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)])))); Nil)) in (inits := sx_append_b !inits (nth (bindings) ((prim_call "inc" [(prim_call "*" [pair_idx; (Number 2.0)])]))); Nil))) Nil (sx_to_list (prim_call "range" [(Number 0.0); (prim_call "/" [(len (bindings)); (Number 2.0)])]))))) in (let loop_body = (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (first (body)) else (cons ((make_symbol ((String "begin")))) (body))) in let loop_fn = (make_lambda (!params) (loop_body) (env)) in (let () = ignore ((set_lambda_name loop_fn (sx_to_string loop_name))) in (let () = ignore ((env_bind (lambda_closure (loop_fn)) (sx_to_string loop_name) loop_fn)) in (let init_vals = (List (List.map (fun e -> (trampoline ((eval_expr (e) (env))))) (sx_to_list !inits))) in (cek_call (loop_fn) (init_vals))))))))
|
|
|
|
(* sf-lambda *)
|
|
and sf_lambda args env =
|
|
(let params_expr = (first (args)) in let body_exprs = (rest (args)) in let body = (if sx_truthy ((prim_call "=" [(len (body_exprs)); (Number 1.0)])) then (first (body_exprs)) else (cons ((make_symbol ((String "begin")))) (body_exprs))) in let param_names = (List (List.map (fun p -> (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (p)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (p)); (Number 3.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (p) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (p) ((Number 1.0))))); (String "as")]))))) then (symbol_name ((first (p)))) else p))) (sx_to_list params_expr))) in (make_lambda (param_names) (body) (env)))
|
|
|
|
(* sf-defcomp *)
|
|
and sf_defcomp args env =
|
|
(let name_sym = (first (args)) in let params_raw = (nth (args) ((Number 1.0))) in let body = (last (args)) in let comp_name = (strip_prefix ((symbol_name (name_sym))) ((String "~"))) in let parsed = (parse_comp_params (params_raw)) in let params = (first (parsed)) in let has_children = (nth (parsed) ((Number 1.0))) in let param_types = (nth (parsed) ((Number 2.0))) in let affinity = (defcomp_kwarg (args) ((String "affinity")) ((String "auto"))) in (let comp = (make_component (comp_name) (params) (has_children) (body) (env) (affinity)) in let effects = (defcomp_kwarg (args) ((String "effects")) (Nil)) in (let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy ((is_nil (param_types)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((empty_p ((prim_call "keys" [param_types]))))))))) then (component_set_param_types_b (comp) (param_types)) else Nil)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((is_nil (effects))))))) then (let effect_list = (if sx_truthy ((prim_call "=" [(type_of (effects)); (String "list")])) then (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else (String (sx_str [e])))) (sx_to_list effects))) else (List [(String (sx_str [effects]))])) in let effect_anns = (if sx_truthy ((env_has (env) ((String "*effect-annotations*")))) then (env_get (env) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns (symbol_name (name_sym)) effect_list)) in (env_bind env (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (let () = ignore ((if sx_truthy ((env_has (env) ((String "*current-file*")))) then (component_set_file_b (comp) ((env_get (env) ((String "*current-file*"))))) else Nil)) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) comp)) in comp))))))
|
|
|
|
(* defcomp-kwarg *)
|
|
and defcomp_kwarg args key default =
|
|
(let end' = (prim_call "-" [(len (args)); (Number 1.0)]) in let result' = ref (default) in (let () = ignore ((List.iter (fun i -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of ((nth (args) (i)))); (String "keyword")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(keyword_name ((nth (args) (i)))); key]) in if not (sx_truthy _and) then _and else (prim_call "<" [(prim_call "+" [i; (Number 1.0)]); end'])))) then (let val' = (nth (args) ((prim_call "+" [i; (Number 1.0)]))) in (result' := (if sx_truthy ((prim_call "=" [(type_of (val')); (String "keyword")])) then (keyword_name (val')) else val'); Nil)) else Nil))) (sx_to_list (prim_call "range" [(Number 2.0); end'; (Number 1.0)])); Nil)) in !result'))
|
|
|
|
(* parse-comp-params *)
|
|
and parse_comp_params params_expr =
|
|
(let params = ref ((List [])) in let param_types = (Dict (Hashtbl.create 0)) in let has_children = ref ((Bool false)) in let in_key = ref ((Bool false)) in (let () = ignore ((List.iter (fun p -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (p)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (p)); (Number 3.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (p)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (p) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (p) ((Number 1.0))))); (String "as")])))))) then (let name = (symbol_name ((first (p)))) in let ptype = (nth (p) ((Number 2.0))) in (let type_val = (if sx_truthy ((prim_call "=" [(type_of (ptype)); (String "symbol")])) then (symbol_name (ptype)) else ptype) in (if sx_truthy ((Bool (not (sx_truthy (!has_children))))) then (let () = ignore ((params := sx_append_b !params name; Nil)) in (sx_dict_set_b param_types name type_val)) else Nil))) else (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (let name = (symbol_name (p)) in (if sx_truthy ((prim_call "=" [name; (String "&key")])) then (in_key := (Bool true); Nil) else (if sx_truthy ((prim_call "=" [name; (String "&rest")])) then (has_children := (Bool true); Nil) else (if sx_truthy ((prim_call "=" [name; (String "&children")])) then (has_children := (Bool true); Nil) else (if sx_truthy (!has_children) then Nil else (if sx_truthy (!in_key) then (params := sx_append_b !params name; Nil) else (params := sx_append_b !params name; Nil))))))) else Nil)))) (sx_to_list params_expr); Nil)) in (List [!params; !has_children; param_types])))
|
|
|
|
(* sf-defisland *)
|
|
and sf_defisland args env =
|
|
(let name_sym = (first (args)) in let params_raw = (nth (args) ((Number 1.0))) in let body_exprs = (prim_call "slice" [args; (Number 2.0)]) in let body = (if sx_truthy ((prim_call "=" [(len (body_exprs)); (Number 1.0)])) then (first (body_exprs)) else (cons ((make_symbol ((String "begin")))) (body_exprs))) in let comp_name = (strip_prefix ((symbol_name (name_sym))) ((String "~"))) in let parsed = (parse_comp_params (params_raw)) in let params = (first (parsed)) in let has_children = (nth (parsed) ((Number 1.0))) in (let island = (make_island (comp_name) (params) (has_children) (body) (env)) in (let () = ignore ((if sx_truthy ((env_has (env) ((String "*current-file*")))) then (component_set_file_b (island) ((env_get (env) ((String "*current-file*"))))) else Nil)) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) island)) in island))))
|
|
|
|
(* defio-parse-kwargs! *)
|
|
and defio_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)))) (nth (remaining) ((Number 1.0))))) in (defio_parse_kwargs_b (spec) ((rest ((rest (remaining))))))) else Nil)
|
|
|
|
(* sf-defio *)
|
|
and sf_defio args env =
|
|
(let name = (first (args)) in let spec = (Dict (Hashtbl.create 0)) in (let () = ignore ((sx_dict_set_b spec (String "name") name)) in (let () = ignore ((defio_parse_kwargs_b (spec) ((rest (args))))) in (let () = ignore ((io_register_b (name) (spec))) in spec))))
|
|
|
|
(* sf-defmacro *)
|
|
and sf_defmacro args env =
|
|
(let name_sym = (first (args)) in let params_raw = (nth (args) ((Number 1.0))) in let body = (nth (args) ((Number 2.0))) in let parsed = (parse_macro_params (params_raw)) in let params = (first (parsed)) in let rest_param = (nth (parsed) ((Number 1.0))) in (let mac = (make_macro (params) (rest_param) (body) (env) ((symbol_name (name_sym)))) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (name_sym))) mac)) in mac)))
|
|
|
|
(* parse-macro-params *)
|
|
and parse_macro_params params_expr =
|
|
(let params = ref ((List [])) in let rest_param = ref (Nil) in (let () = ignore ((List.fold_left (fun state p -> (if sx_truthy ((let _and = (prim_call "=" [(type_of (p)); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (p)); (String "&rest")]))) then (prim_call "assoc" [state; (String "in-rest"); (Bool true)]) else (if sx_truthy ((get (state) ((String "in-rest")))) then (let () = ignore ((rest_param := (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else p); Nil)) in state) else (let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else p); Nil)) in state)))) (let _d = Hashtbl.create 1 in Hashtbl.replace _d (value_to_str (String "in-rest")) (Bool false); Dict _d) (sx_to_list params_expr))) in (List [!params; !rest_param])))
|
|
|
|
(* qq-expand *)
|
|
and qq_expand template env =
|
|
(if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (template)); (String "list")])))))) then template else (if sx_truthy ((empty_p (template))) then (List []) else (let head = (first (template)) in (if sx_truthy ((let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (head)); (String "unquote")]))) then (trampoline ((eval_expr ((nth (template) ((Number 1.0)))) (env)))) else (List.fold_left (fun result' item -> (if sx_truthy ((let _and = (prim_call "=" [(type_of (item)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (item)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (item)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (item)))); (String "splice-unquote")]))))) then (let spliced = (trampoline ((eval_expr ((nth (item) ((Number 1.0)))) (env)))) in (if sx_truthy ((prim_call "=" [(type_of (spliced)); (String "list")])) then (prim_call "concat" [result'; spliced]) else (if sx_truthy ((is_nil (spliced))) then result' else (prim_call "concat" [result'; (List [spliced])])))) else (prim_call "concat" [result'; (List [(qq_expand (item) (env))])]))) (List []) (sx_to_list template))))))
|
|
|
|
(* sf-letrec *)
|
|
and sf_letrec args env =
|
|
(let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in let names = ref ((List [])) in let val_exprs = ref ((List [])) in (let () = ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (List.iter (fun binding -> ignore ((let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))) in (let () = ignore ((names := sx_append_b !names vname; Nil)) in (let () = ignore ((val_exprs := sx_append_b !val_exprs (nth (binding) ((Number 1.0))); Nil)) in (env_bind local (sx_to_string vname) Nil)))))) (sx_to_list bindings); Nil) else (List.fold_left (fun _acc pair_idx -> (let vname = (if sx_truthy ((prim_call "=" [(type_of ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))); (String "symbol")])) then (symbol_name ((nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)]))))) else (nth (bindings) ((prim_call "*" [pair_idx; (Number 2.0)])))) in let val_expr = (nth (bindings) ((prim_call "inc" [(prim_call "*" [pair_idx; (Number 2.0)])]))) in (let () = ignore ((names := sx_append_b !names vname; Nil)) in (let () = ignore ((val_exprs := sx_append_b !val_exprs val_expr; Nil)) in (env_bind local (sx_to_string vname) Nil))))) Nil (sx_to_list (prim_call "range" [(Number 0.0); (prim_call "/" [(len (bindings)); (Number 2.0)])]))))) in (let () = ignore ((let values = (List (List.map (fun e -> (trampoline ((eval_expr (e) (local))))) (sx_to_list !val_exprs))) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [!names; values])); Nil)) in (List.iter (fun val' -> ignore ((if sx_truthy ((is_lambda (val'))) then (List.iter (fun n -> ignore ((env_bind (lambda_closure (val')) (sx_to_string n) (env_get (local) (n))))) (sx_to_list !names); Nil) else Nil))) (sx_to_list values); Nil)))) in (let () = ignore ((List.iter (fun e -> ignore ((trampoline ((eval_expr (e) (local)))))) (sx_to_list (prim_call "slice" [body; (Number 0.0); (prim_call "dec" [(len (body))])])); Nil)) in (make_thunk ((last (body))) (local))))))
|
|
|
|
(* step-sf-letrec *)
|
|
and step_sf_letrec args env kont =
|
|
(let thk = (sf_letrec (args) (env)) in (make_cek_state ((thunk_expr (thk))) ((thunk_env (thk))) (kont)))
|
|
|
|
(* sf-dynamic-wind *)
|
|
and sf_dynamic_wind args env =
|
|
(let before = (trampoline ((eval_expr ((first (args))) (env)))) in let body = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in let after = (trampoline ((eval_expr ((nth (args) ((Number 2.0)))) (env)))) in (dynamic_wind_call (before) (body) (after) (env)))
|
|
|
|
(* sf-scope *)
|
|
and sf_scope args env =
|
|
(let name = (trampoline ((eval_expr ((first (args))) (env)))) in let rest = (prim_call "slice" [args; (Number 1.0)]) in let val' = ref (Nil) in let body_exprs = ref (Nil) in (let () = ignore ((if sx_truthy ((let _and = (prim_call ">=" [(len (rest)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (rest)))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((first (rest)))); (String "value")])))) then (let () = ignore ((val' := (trampoline ((eval_expr ((nth (rest) ((Number 1.0)))) (env)))); Nil)) in (body_exprs := (prim_call "slice" [rest; (Number 2.0)]); Nil)) else (body_exprs := rest; Nil))) in (let () = ignore ((scope_push (name) (!val'))) in (let result' = ref (Nil) in (let () = ignore ((List.iter (fun e -> ignore ((result' := (trampoline ((eval_expr (e) (env)))); Nil))) (sx_to_list !body_exprs); Nil)) in (let () = ignore ((scope_pop (name))) in !result'))))))
|
|
|
|
(* sf-provide *)
|
|
and sf_provide args env =
|
|
(let name = (trampoline ((eval_expr ((first (args))) (env)))) in let val' = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in let body_exprs = (prim_call "slice" [args; (Number 2.0)]) in let result' = ref (Nil) in (let () = ignore ((scope_push (name) (val'))) in (let () = ignore ((List.iter (fun e -> ignore ((result' := (trampoline ((eval_expr (e) (env)))); Nil))) (sx_to_list body_exprs); Nil)) in (let () = ignore ((scope_pop (name))) in !result'))))
|
|
|
|
(* expand-macro *)
|
|
and expand_macro mac raw_args env =
|
|
(let body = (macro_body (mac)) in (if sx_truthy ((let _and = (symbol_p (body)) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (body)); (String "__syntax-rules-body__")]))) then (let closure = (macro_closure (mac)) in (syntax_rules_expand ((env_get (closure) ((String "__sr-literals")))) ((env_get (closure) ((String "__sr-rules")))) (raw_args))) else (let local = (env_merge ((macro_closure (mac))) (env)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (if sx_truthy ((prim_call "<" [(nth (pair) ((Number 1.0))); (len (raw_args))])) then (nth (raw_args) ((nth (pair) ((Number 1.0))))) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [p; i])) (sx_to_list (macro_params (mac)))))); Nil)) in (let () = ignore ((if sx_truthy ((macro_rest_param (mac))) then (env_bind local (sx_to_string (macro_rest_param (mac))) (prim_call "slice" [raw_args; (len ((macro_params (mac))))])) else Nil)) in (trampoline ((eval_expr ((macro_body (mac))) (local)))))))))
|
|
|
|
(* cek-step-loop *)
|
|
and cek_step_loop state =
|
|
(if sx_truthy ((let _or = (cek_terminal_p (state)) in if sx_truthy _or then _or else (cek_suspended_p (state)))) then state else (cek_step_loop ((cek_step (state)))))
|
|
|
|
(* cek-run *)
|
|
and cek_run state =
|
|
(let final = (cek_step_loop (state)) in (if sx_truthy ((cek_suspended_p (final))) then (raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))) else (cek_value (final))))
|
|
|
|
(* cek-resume *)
|
|
and cek_resume suspended_state result' =
|
|
(cek_step_loop ((make_cek_value (result') ((cek_env (suspended_state))) ((cek_kont (suspended_state))))))
|
|
|
|
(* cek-step *)
|
|
and cek_step state =
|
|
(if sx_truthy ((prim_call "=" [(cek_phase (state)); (String "eval")])) then (step_eval (state)) else (step_continue (state)))
|
|
|
|
(* step-eval *)
|
|
and step_eval state =
|
|
(let expr = (cek_control (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (let _match_val = (type_of (expr)) in (if _match_val = (String "number") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "string") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "boolean") then (make_cek_value (expr) (env) (kont)) else (if _match_val = (String "nil") then (make_cek_value (Nil) (env) (kont)) else (if _match_val = (String "symbol") then (let name = (symbol_name (expr)) in (let val' = (if sx_truthy ((env_has (env) (name))) then (env_get (env) (name)) else (if sx_truthy ((is_primitive (name))) then (get_primitive (name)) else (if sx_truthy ((prim_call "=" [name; (String "true")])) then (Bool true) else (if sx_truthy ((prim_call "=" [name; (String "false")])) then (Bool false) else (if sx_truthy ((prim_call "=" [name; (String "nil")])) then Nil else (match !_symbol_resolve_hook with Some hook -> (match hook (value_to_str name) with Some v -> v | None -> raise (Eval_error ("Undefined symbol: " ^ value_to_str name))) | None -> raise (Eval_error ("Undefined symbol: " ^ value_to_str name)))))))) in (let () = ignore ((if sx_truthy ((let _and = (is_nil (val')) in if not (sx_truthy _and) then _and else (prim_call "starts-with?" [name; (String "~")]))) then (debug_log ((String "Component not found:")) (name)) else Nil)) in (make_cek_value (val') (env) (kont))))) else (if _match_val = (String "keyword") then (make_cek_value ((keyword_name (expr))) (env) (kont)) else (if _match_val = (String "dict") then (let ks = (prim_call "keys" [expr]) in (if sx_truthy ((empty_p (ks))) then (make_cek_value ((Dict (Hashtbl.create 0))) (env) (kont)) else (let first_key = (first (ks)) in let remaining_entries = ref ((List [])) in (let () = ignore ((List.iter (fun k -> ignore ((remaining_entries := sx_append_b !remaining_entries (List [k; (get (expr) (k))]); Nil))) (sx_to_list (rest (ks))); Nil)) in (make_cek_state ((get (expr) (first_key))) (env) ((kont_push ((make_dict_frame (!remaining_entries) ((List [(List [first_key])])) (env))) (kont)))))))) else (if _match_val = (String "list") then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (step_eval_list (expr) (env) (kont))) else (make_cek_value (expr) (env) (kont))))))))))))
|
|
|
|
(* step-sf-raise *)
|
|
and step_sf_raise args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_raise_eval_frame (env) ((Bool false)))) (kont))))
|
|
|
|
(* step-sf-guard *)
|
|
and step_sf_guard args env kont =
|
|
(let var_clauses = (first (args)) in let body = (rest (args)) in let var = (first (var_clauses)) in let clauses = (rest (var_clauses)) in let sentinel = (make_symbol ((String "__guard-reraise__"))) in (step_eval_list ((List [(Symbol "let"); (List [(List [(Symbol "__guard-result"); (cons ((Symbol "call/cc")) ((List [(cons ((Symbol "fn")) ((cons ((List [(Symbol "__guard-k")])) ((List [(cons ((Symbol "handler-bind")) ((cons ((List [(List [(cons ((Symbol "fn")) ((cons ((List [(Symbol "_")])) ((List [(Bool true)]))))); (cons ((Symbol "fn")) ((cons ((List [var])) ((List [(List [(Symbol "__guard-k"); (cons ((Symbol "cond")) ((prim_call "append" [clauses; (List [(List [(Symbol "else"); (List [(Symbol "list"); (List [(Symbol "quote"); sentinel]); var])])])])))])])))))])])) ((List [(List [(Symbol "__guard-k"); (cons ((Symbol "begin")) (body))])])))))])))))])))])]); (List [(Symbol "if"); (List [(Symbol "and"); (List [(Symbol "list?"); (Symbol "__guard-result")]); (List [(Symbol "="); (List [(Symbol "len"); (Symbol "__guard-result")]); (Number 2.0)]); (List [(Symbol "="); (List [(Symbol "first"); (Symbol "__guard-result")]); (List [(Symbol "quote"); sentinel])])]); (List [(Symbol "raise"); (List [(Symbol "nth"); (Symbol "__guard-result"); (Number 1.0)])]); (Symbol "__guard-result")])])) (env) (kont)))
|
|
|
|
(* step-sf-callcc *)
|
|
and step_sf_callcc args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_callcc_frame (env))) (kont))))
|
|
|
|
(* step-sf-case *)
|
|
and step_sf_case args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_case_frame (Nil) ((rest (args))) (env))) (kont))))
|
|
|
|
(* step-sf-let-match *)
|
|
and step_sf_let_match args env kont =
|
|
(let pattern = (first (args)) in let expr = (nth (args) ((Number 1.0))) in let body = (rest ((rest (args)))) in (step_sf_match ((List [expr; (List [pattern; (cons ((Symbol "begin")) (body))])])) (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 "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler-bind")])) then (step_sf_handler_bind (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart-case")])) then (step_sf_restart_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-condition")])) then (step_sf_signal (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "invoke-restart")])) then (step_sf_invoke_restart (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "match")])) then (step_sf_match (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [_match_val; (String "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)))))
|
|
|
|
(* step-sf-parameterize *)
|
|
and step_sf_parameterize args env kont =
|
|
(let bindings = (first (args)) in let body = (rest (args)) in (if sx_truthy ((let _or = (is_nil (bindings)) in if sx_truthy _or then _or else (empty_p (bindings)))) then (step_sf_begin (body) (env) (kont)) else (let first_pair = (first (bindings)) in (make_cek_state ((first (first_pair))) (env) ((kont_push ((make_parameterize_frame (bindings) (Nil) ((List [])) (body) (env))) (kont)))))))
|
|
|
|
(* syntax-rules-match *)
|
|
and syntax_rules_match pattern form literals =
|
|
(if sx_truthy ((let _and = (symbol_p (pattern)) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (pattern)); (String "_")]))) then (Dict (Hashtbl.create 0)) else (if sx_truthy ((let _and = (symbol_p (pattern)) in if not (sx_truthy _and) then _and else (prim_call "contains?" [literals; (symbol_name (pattern))]))) then (if sx_truthy ((let _and = (symbol_p (form)) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (pattern)); (symbol_name (form))]))) then (Dict (Hashtbl.create 0)) else Nil) else (if sx_truthy ((symbol_p (pattern))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((sx_dict_set_b d (symbol_name (pattern)) form)) in d)) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (empty_p (pattern)))) then (if sx_truthy ((let _and = (list_p (form)) in if not (sx_truthy _and) then _and else (empty_p (form)))) then (Dict (Hashtbl.create 0)) else Nil) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (list_p (form)))) then (syntax_rules_match_list (pattern) ((Number 0.0)) (form) ((Number 0.0)) (literals)) else (if sx_truthy ((prim_call "=" [pattern; form])) then (Dict (Hashtbl.create 0)) else Nil))))))
|
|
|
|
(* syntax-rules-match-list *)
|
|
and syntax_rules_match_list pattern pi form fi literals =
|
|
(let plen = (len (pattern)) in let flen = (len (form)) in (if sx_truthy ((let _and = (prim_call ">=" [pi; plen]) in if not (sx_truthy _and) then _and else (prim_call ">=" [fi; flen]))) then (Dict (Hashtbl.create 0)) else (if sx_truthy ((prim_call ">=" [pi; plen])) then Nil else (if sx_truthy ((let _and = (prim_call "<" [(prim_call "+" [pi; (Number 1.0)]); plen]) in if not (sx_truthy _and) then _and else (let _and = (symbol_p ((nth (pattern) ((prim_call "+" [pi; (Number 1.0)]))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (pattern) ((prim_call "+" [pi; (Number 1.0)]))))); (String "...")])))) then (let sub_pat = (nth (pattern) (pi)) in let rest_pat_count = (prim_call "-" [plen; (prim_call "+" [pi; (Number 2.0)])]) in let available = (prim_call "-" [flen; fi]) in let n_ellipsis = (prim_call "-" [(prim_call "-" [flen; fi]); (prim_call "-" [plen; (prim_call "+" [pi; (Number 2.0)])])]) in (if sx_truthy ((prim_call "<" [n_ellipsis; (Number 0.0)])) then Nil else (let ellipsis_forms = (prim_call "slice" [form; fi; (prim_call "+" [fi; n_ellipsis])]) in let sub_bindings = (List (List.map (fun f -> (syntax_rules_match (sub_pat) (f) (literals))) (sx_to_list (prim_call "slice" [form; fi; (prim_call "+" [fi; n_ellipsis])])))) in (if sx_truthy ((prim_call "contains?" [sub_bindings; Nil])) then Nil else (let rest_result = (syntax_rules_match_list (pattern) ((prim_call "+" [pi; (Number 2.0)])) (form) ((prim_call "+" [fi; n_ellipsis])) (literals)) in (if sx_truthy ((is_nil (rest_result))) then Nil else (let merged = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun b -> ignore ((List.iter (fun key -> ignore ((let existing = (dict_get (merged) (key)) in (if sx_truthy ((is_nil (existing))) then (sx_dict_set_b merged key (List [(get (b) (key))])) else (sx_dict_set_b merged key (prim_call "append" [existing; (List [(get (b) (key))])])))))) (sx_to_list (prim_call "keys" [b])); Nil))) (sx_to_list sub_bindings); Nil)) in (let () = ignore ((List.iter (fun key -> ignore ((sx_dict_set_b merged key (get (rest_result) (key))))) (sx_to_list (prim_call "keys" [rest_result])); Nil)) in merged))))))))) else (if sx_truthy ((prim_call ">=" [fi; flen])) then Nil else (let sub_result = (syntax_rules_match ((nth (pattern) (pi))) ((nth (form) (fi))) (literals)) in (if sx_truthy ((is_nil (sub_result))) then Nil else (let rest_result = (syntax_rules_match_list (pattern) ((prim_call "+" [pi; (Number 1.0)])) (form) ((prim_call "+" [fi; (Number 1.0)])) (literals)) in (if sx_truthy ((is_nil (rest_result))) then Nil else (let () = ignore ((List.iter (fun key -> ignore ((sx_dict_set_b rest_result key (get (sub_result) (key))))) (sx_to_list (prim_call "keys" [sub_result])); Nil)) in rest_result))))))))))
|
|
|
|
(* syntax-rules-find-var *)
|
|
and syntax_rules_find_var template bindings =
|
|
(if sx_truthy ((let _and = (symbol_p (template)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "has-key?" [bindings; (symbol_name (template))]) in if not (sx_truthy _and) then _and else (list_p ((get (bindings) ((symbol_name (template))))))))) then (symbol_name (template)) else (if sx_truthy ((list_p (template))) then (List.fold_left (fun found t -> (if sx_truthy ((is_nil (found))) then (syntax_rules_find_var (t) (bindings)) else found)) Nil (sx_to_list template)) else Nil))
|
|
|
|
(* syntax-rules-find-all-vars *)
|
|
and syntax_rules_find_all_vars template bindings =
|
|
(if sx_truthy ((let _and = (symbol_p (template)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "has-key?" [bindings; (symbol_name (template))]) in if not (sx_truthy _and) then _and else (list_p ((get (bindings) ((symbol_name (template))))))))) then (List [(symbol_name (template))]) else (if sx_truthy ((list_p (template))) then (List.fold_left (fun acc t -> (prim_call "append" [acc; (syntax_rules_find_all_vars (t) (bindings))])) (List []) (sx_to_list template)) else (List [])))
|
|
|
|
(* syntax-rules-instantiate *)
|
|
and syntax_rules_instantiate template bindings =
|
|
(if sx_truthy ((let _and = (symbol_p (template)) in if not (sx_truthy _and) then _and else (prim_call "has-key?" [bindings; (symbol_name (template))]))) then (get (bindings) ((symbol_name (template)))) else (if sx_truthy ((Bool (not (sx_truthy ((list_p (template))))))) then template else (if sx_truthy ((empty_p (template))) then template else (syntax_rules_instantiate_list (template) ((Number 0.0)) (bindings)))))
|
|
|
|
(* syntax-rules-instantiate-list *)
|
|
and syntax_rules_instantiate_list template i bindings =
|
|
(if sx_truthy ((prim_call ">=" [i; (len (template))])) then (List []) else (let elem = (nth (template) (i)) in let has_ellipsis = (let _and = (prim_call "<" [(prim_call "+" [i; (Number 1.0)]); (len (template))]) in if not (sx_truthy _and) then _and else (let _and = (symbol_p ((nth (template) ((prim_call "+" [i; (Number 1.0)]))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (template) ((prim_call "+" [i; (Number 1.0)]))))); (String "...")]))) in (if sx_truthy (has_ellipsis) then (let all_vars = (syntax_rules_find_all_vars (elem) (bindings)) in (if sx_truthy ((empty_p (all_vars))) then (syntax_rules_instantiate_list (template) ((prim_call "+" [i; (Number 2.0)])) (bindings)) else (let count = (len ((get (bindings) ((first (all_vars)))))) in let expanded = (List (List.map (fun idx -> (let b = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun key -> ignore ((sx_dict_set_b b key (get (bindings) (key))))) (sx_to_list (prim_call "keys" [bindings])); Nil)) in (let () = ignore ((List.iter (fun var_name -> ignore ((sx_dict_set_b b var_name (nth ((get (bindings) (var_name))) (idx))))) (sx_to_list all_vars); Nil)) in (syntax_rules_instantiate (elem) (b)))))) (sx_to_list (prim_call "range" [count])))) in let rest_result = (syntax_rules_instantiate_list (template) ((prim_call "+" [i; (Number 2.0)])) (bindings)) in (prim_call "append" [expanded; rest_result])))) else (cons ((syntax_rules_instantiate (elem) (bindings))) ((syntax_rules_instantiate_list (template) ((prim_call "+" [i; (Number 1.0)])) (bindings)))))))
|
|
|
|
(* syntax-rules-expand *)
|
|
and syntax_rules_expand literals rules form =
|
|
(let full_form = (cons ((make_symbol ((String "_")))) (form)) in (syntax_rules_try_rules (literals) (rules) (full_form)))
|
|
|
|
(* syntax-rules-try-rules *)
|
|
and syntax_rules_try_rules literals rules full_form =
|
|
(if sx_truthy ((empty_p (rules))) then (raise (Eval_error (value_to_str (String (sx_str [(String "syntax-rules: no pattern matched for "); (inspect (full_form))]))))) else (let rule = (first (rules)) in let pattern = (first (rule)) in let template = (nth (rule) ((Number 1.0))) in (let bindings = (syntax_rules_match (pattern) (full_form) (literals)) in (if sx_truthy ((Bool (not (sx_truthy ((is_nil (bindings))))))) then (syntax_rules_instantiate (template) (bindings)) else (syntax_rules_try_rules (literals) ((rest (rules))) (full_form))))))
|
|
|
|
(* sf-syntax-rules *)
|
|
and sf_syntax_rules args env =
|
|
(let literals = (if sx_truthy ((list_p ((first (args))))) then (List (List.map (fun s -> (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s])))) (sx_to_list (first (args))))) else (List [])) in let rules = (rest (args)) in (let closure = (env_extend (env)) in (let () = ignore ((env_bind closure (sx_to_string (String "__sr-literals")) literals)) in (let () = ignore ((env_bind closure (sx_to_string (String "__sr-rules")) rules)) in (make_macro ((List [])) ((String "__sr-form")) ((Symbol "__syntax-rules-body__")) (closure) ((String "syntax-rules")))))))
|
|
|
|
(* step-sf-define-library *)
|
|
and step_sf_define_library args env kont =
|
|
(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 "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 =
|
|
(let head = (if sx_truthy ((let _and = (list_p (import_set)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (import_set)))))) in if not (sx_truthy _and) then _and else (symbol_p ((first (import_set))))))) then (symbol_name ((first (import_set)))) else Nil) in (let lib_spec = (if sx_truthy ((let _or = (prim_call "=" [head; (String "only")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [head; (String "except")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [head; (String "prefix")]) in if sx_truthy _or then _or else (prim_call "=" [head; (String "rename")]))))) then (nth (import_set) ((Number 1.0))) else import_set) in (let exports = (library_exports (lib_spec)) in (if sx_truthy ((prim_call "=" [head; (String "only")])) then (List.iter (fun s -> ignore ((let id = (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s]))) in (if sx_truthy ((prim_call "has-key?" [exports; id])) then (env_bind env (sx_to_string id) (get (exports) (id))) else Nil)))) (sx_to_list (rest ((rest (import_set))))); Nil) else (if sx_truthy ((prim_call "=" [head; (String "prefix")])) then (let pfx = (String (sx_str [(nth (import_set) ((Number 2.0)))])) in (List.iter (fun key -> ignore ((env_bind env (sx_to_string (String (sx_str [pfx; key]))) (get (exports) (key))))) (sx_to_list (prim_call "keys" [exports])); Nil)) else (List.iter (fun key -> ignore ((env_bind env (sx_to_string key) (get (exports) (key))))) (sx_to_list (prim_call "keys" [exports])); Nil))))))
|
|
|
|
(* step-sf-import *)
|
|
and step_sf_import args env kont =
|
|
(if sx_truthy ((empty_p (args))) then (make_cek_value (Nil) (env) (kont)) else (let import_set = (first (args)) in let rest_sets = (rest (args)) in (let lib_spec = (let head = (if sx_truthy ((let _and = (list_p (import_set)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (import_set)))))) in if not (sx_truthy _and) then _and else (symbol_p ((first (import_set))))))) then (symbol_name ((first (import_set)))) else Nil) in (if sx_truthy ((let _or = (prim_call "=" [head; (String "only")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [head; (String "except")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [head; (String "prefix")]) in if sx_truthy _or then _or else (prim_call "=" [head; (String "rename")]))))) then (nth (import_set) ((Number 1.0))) else import_set)) in (if sx_truthy ((library_loaded_p (lib_spec))) then (let () = ignore ((bind_import_set (import_set) (env))) in (if sx_truthy ((empty_p (rest_sets))) then (make_cek_value (Nil) (env) (kont)) else (step_sf_import (rest_sets) (env) (kont)))) else (make_cek_suspended ((let _d = Hashtbl.create 2 in Hashtbl.replace _d "library" lib_spec; Hashtbl.replace _d "op" (String "import"); Dict _d)) (env) ((kont_push ((make_import_frame (import_set) (rest_sets) (env))) (kont))))))))
|
|
|
|
(* step-sf-perform *)
|
|
and step_sf_perform args env kont =
|
|
(if sx_truthy ((empty_p (args))) then (raise (Eval_error (value_to_str (String "perform requires an IO request argument")))) else (make_cek_state ((first (args))) (env) ((kont_push ((make_perform_frame (env))) (kont)))))
|
|
|
|
|
|
(* sf-define-record-type *)
|
|
and sf_define_record_type args env =
|
|
(let type_sym = (first (args)) in let ctor_spec = (nth (args) ((Number 1.0))) in let pred_sym = (nth (args) ((Number 2.0))) in let field_specs = (prim_call "slice" [args; (Number 3.0)]) in (let raw_name = (symbol_name (type_sym)) in (let type_name = (if sx_truthy ((let _and = (prim_call "starts-with?" [raw_name; (String "<")]) in if not (sx_truthy _and) then _and else (prim_call "ends-with?" [raw_name; (String ">")]))) then (prim_call "slice" [raw_name; (Number 1.0); (prim_call "-" [(len (raw_name)); (Number 1.0)])]) else raw_name) in let ctor_name = (symbol_name ((first (ctor_spec)))) in let ctor_params = (List (List.map (fun s -> (symbol_name (s))) (sx_to_list (rest (ctor_spec))))) in let pred_name = (symbol_name (pred_sym)) in let field_names = (List (List.map (fun fs -> (symbol_name ((first (fs))))) (sx_to_list field_specs))) in (let rtd_uid = (make_rtd (type_name) (field_names) (ctor_params)) in (let () = ignore ((env_bind env (sx_to_string ctor_name) (make_record_constructor (rtd_uid)))) in (let () = ignore ((env_bind env (sx_to_string pred_name) (make_record_predicate (rtd_uid)))) in (let () = ignore ((for_each_indexed ((NativeFn ("\206\187", fun _args -> match _args with [idx; fs] -> (fun idx fs -> (let accessor_name = (symbol_name ((nth (fs) ((Number 1.0))))) in (let () = ignore ((env_bind env (sx_to_string accessor_name) (make_record_accessor (idx)))) in (if sx_truthy ((prim_call ">=" [(len (fs)); (Number 3.0)])) then (let mutator_name = (symbol_name ((nth (fs) ((Number 2.0))))) in (env_bind env (sx_to_string mutator_name) (make_record_mutator (idx)))) else Nil)))) idx fs | _ -> Nil))) (field_specs))) in Nil)))))))
|
|
|
|
(* sf-define-protocol *)
|
|
and sf_define_protocol args env =
|
|
(let proto_name = (symbol_name ((first (args)))) in let method_specs = (rest (args)) in (let () = ignore ((let () = ignore ((env_bind env (sx_to_string (String "*protocol-registry*")) _protocol_registry_)) in (env_bind env (sx_to_string (String "satisfies?")) (NativeFn ("\206\187", fun _args -> match _args with [pname; val'] -> (fun pname val' -> (satisfies_p (pname) (val'))) pname val' | _ -> Nil))))) in (let () = ignore ((sx_dict_set_b _protocol_registry_ proto_name (let _d = Hashtbl.create 3 in Hashtbl.replace _d "impls" (Dict (Hashtbl.create 0)); Hashtbl.replace _d "methods" (List (List.map (fun spec -> (let _d = Hashtbl.create 2 in Hashtbl.replace _d "arity" (len (spec)); Hashtbl.replace _d "name" (symbol_name ((first (spec)))); Dict _d)) (sx_to_list method_specs))); Hashtbl.replace _d "name" proto_name; Dict _d))) in (let () = ignore ((List.iter (fun spec -> ignore ((let method_name = (symbol_name ((first (spec)))) in let params = (rest (spec)) in let pname = proto_name in (let self_sym = (first (params)) in let lookup_expr = (List [(Symbol "get"); (List [(Symbol "get"); (List [(Symbol "get"); (List [(Symbol "get"); (Symbol "*protocol-registry*"); pname]); (String "impls")]); (List [(Symbol "type-of"); self_sym])]); method_name]) in (env_bind env (sx_to_string method_name) (eval_expr ((List [(Symbol "fn"); params; (List [(Symbol "let"); (List [(List [(Symbol "_impl"); lookup_expr])]); (List [(Symbol "if"); (List [(Symbol "nil?"); (Symbol "_impl")]); (List [(Symbol "error"); (String (sx_str [pname; (String "."); method_name; (String ": not implemented for this type")]))]); (cons ((Symbol "_impl")) (params))])])])) (env))))))) (sx_to_list method_specs); Nil)) in Nil))))
|
|
|
|
(* sf-implement *)
|
|
and sf_implement args env =
|
|
(let proto_name = (symbol_name ((first (args)))) in let raw_type_name = (symbol_name ((nth (args) ((Number 1.0))))) in let type_name = (prim_call "slice" [raw_type_name; (Number 1.0); (prim_call "-" [(len (raw_type_name)); (Number 1.0)])]) in let method_defs = (rest ((rest (args)))) in (let proto = (get (_protocol_registry_) (proto_name)) in (if sx_truthy ((is_nil (proto))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown protocol: "); proto_name]))))) else (let impls = (get (proto) ((String "impls"))) in let type_impls = (let _or = (get (impls) (type_name)) in if sx_truthy _or then _or else (Dict (Hashtbl.create 0))) in (let () = ignore ((List.iter (fun method_def -> ignore ((let mname = (symbol_name ((first (method_def)))) in let proto_method = (first ((List (List.filter (fun m -> sx_truthy ((prim_call "=" [(get (m) ((String "name"))); mname]))) (sx_to_list (get (proto) ((String "methods")))))))) in (if sx_truthy ((is_nil (proto_method))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown method "); mname; (String " in protocol "); proto_name]))))) else (let arity = (get (proto_method) ((String "arity"))) in let params = (prim_call "slice" [method_def; (Number 1.0); arity]) in let body = (if sx_truthy ((prim_call "=" [(len (method_def)); (prim_call "+" [arity; (Number 1.0)])])) then (nth (method_def) (arity)) else (cons ((Symbol "begin")) ((prim_call "slice" [method_def; arity])))) in (sx_dict_set_b type_impls mname (eval_expr ((List [(Symbol "fn"); params; body])) (env)))))))) (sx_to_list method_defs); Nil)) in (let () = ignore ((sx_dict_set_b impls type_name type_impls)) in Nil))))))
|
|
|
|
(* satisfies? *)
|
|
and satisfies_p proto_name value =
|
|
(if sx_truthy ((Bool (not (sx_truthy ((record_p (value))))))) then (Bool false) else (let proto = (get (_protocol_registry_) ((if sx_truthy ((symbol_p (proto_name))) then (symbol_name (proto_name)) else proto_name))) in (if sx_truthy ((is_nil (proto))) then (Bool false) else (Bool (not (sx_truthy ((is_nil ((get ((get (proto) ((String "impls")))) ((type_of (value)))))))))))))
|
|
|
|
(* check-match-exhaustiveness *)
|
|
and check_match_exhaustiveness clauses =
|
|
(let warnings = ref ((List [])) in let patterns = (List (List.map (fun c -> (first (c))) (sx_to_list clauses))) in let has_wildcard = (Bool (List.exists (fun p -> sx_truthy ((let _and = (symbol_p (p)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [p; (Bool true)]))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((prim_call "=" [p; (Bool false)]))))))))) (sx_to_list patterns))) in let has_else = (Bool (List.exists (fun p -> sx_truthy ((prim_call "=" [p; (String "else")]))) (sx_to_list patterns))) in let has_true = (Bool (List.exists (fun p -> sx_truthy ((prim_call "=" [p; (Bool true)]))) (sx_to_list patterns))) in let has_false = (Bool (List.exists (fun p -> sx_truthy ((prim_call "=" [p; (Bool false)]))) (sx_to_list patterns))) in (let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy (has_wildcard)))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (has_else)))))) then (warnings := (prim_call "append" [!warnings; (List [(String "match may be non-exhaustive (no wildcard or :else pattern)")])]); Nil) else Nil)) in (let () = ignore ((if sx_truthy ((let _and = (let _or = has_true in if sx_truthy _or then _or else has_false) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((let _and = has_true in if not (sx_truthy _and) then _and else has_false))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy (has_wildcard)))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (has_else)))))))) then (warnings := (prim_call "append" [!warnings; (List [(if sx_truthy (has_true) then (String "match on boolean missing false case") else (String "match on boolean missing true case"))])]); Nil) else Nil)) in !warnings)))
|
|
|
|
(* match-find-clause *)
|
|
and match_find_clause val' clauses env =
|
|
(if sx_truthy ((empty_p (clauses))) then Nil else (let clause = (first (clauses)) in let pattern = (first (clause)) in let body = (nth (clause) ((Number 1.0))) in let local = (env_extend (env)) in (if sx_truthy ((match_pattern (pattern) (val') (local))) then (List [local; body]) else (match_find_clause (val') ((rest (clauses))) (env)))))
|
|
|
|
(* match-pattern *)
|
|
and match_pattern pattern value env =
|
|
(if sx_truthy ((prim_call "=" [pattern; (Symbol "_")])) then (Bool true) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(len (pattern)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "?")])))) then (let pred = (eval_expr ((nth (pattern) ((Number 1.0)))) (env)) in (cek_call (pred) ((List [value])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (pattern)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(first (pattern)); (Symbol "quote")])))) then (prim_call "=" [value; (nth (pattern) ((Number 1.0)))]) else (if sx_truthy ((symbol_p (pattern))) then (let () = ignore ((env_bind env (sx_to_string (symbol_name (pattern))) value)) in (Bool true)) else (if sx_truthy ((let _and = (dict_p (pattern)) in if not (sx_truthy _and) then _and else (dict_p (value)))) then (Bool (List.for_all (fun k -> sx_truthy ((match_pattern ((get (pattern) (k))) ((get (value) (k))) (env)))) (sx_to_list (prim_call "keys" [pattern])))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (let _and = (list_p (value)) in if not (sx_truthy _and) then _and else (prim_call "contains?" [pattern; (Symbol "&rest")])))) then (let rest_idx = (prim_call "index-of" [pattern; (Symbol "&rest")]) in (let _and = (prim_call ">=" [(len (value)); rest_idx]) in if not (sx_truthy _and) then _and else (let _and = (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list (prim_call "zip" [(prim_call "slice" [pattern; (Number 0.0); rest_idx]); (prim_call "slice" [value; (Number 0.0); rest_idx])])))) in if not (sx_truthy _and) then _and else (let rest_name = (nth (pattern) ((prim_call "+" [rest_idx; (Number 1.0)]))) in (let () = ignore ((env_bind env (sx_to_string (symbol_name (rest_name))) (prim_call "slice" [value; rest_idx]))) in (Bool true)))))) else (if sx_truthy ((let _and = (list_p (pattern)) in if not (sx_truthy _and) then _and else (list_p (value)))) then (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(len (pattern)); (len (value))])))))) then (Bool false) else (let pairs = (prim_call "zip" [pattern; value]) in (Bool (List.for_all (fun pair -> sx_truthy ((match_pattern ((first (pair))) ((nth (pair) ((Number 1.0)))) (env)))) (sx_to_list pairs))))) else (prim_call "=" [pattern; value]))))))))
|
|
|
|
(* step-sf-match *)
|
|
and step_sf_match args env kont =
|
|
(let val' = (trampoline ((eval_expr ((first (args))) (env)))) in let clauses = (rest (args)) in (let result' = (match_find_clause (val') (clauses) (env)) in (if sx_truthy ((is_nil (result'))) then (raise (Eval_error (value_to_str (String (sx_str [(String "match: no clause matched "); (inspect (val'))]))))) else (make_cek_state ((nth (result') ((Number 1.0)))) ((first (result'))) (kont)))))
|
|
|
|
(* step-sf-handler-bind *)
|
|
and step_sf_handler_bind args env kont =
|
|
(let handler_specs = (first (args)) in let body = (rest (args)) in let handlers = (List (List.map (fun spec -> (List [(trampoline ((eval_expr ((first (spec))) (env)))); (trampoline ((eval_expr ((nth (spec) ((Number 1.0)))) (env))))])) (sx_to_list handler_specs))) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (env) (kont)) else (make_cek_state ((first (body))) (env) ((kont_push ((make_handler_frame (handlers) ((rest (body))) (env))) (kont))))))
|
|
|
|
(* step-sf-restart-case *)
|
|
and step_sf_restart_case args env kont =
|
|
(let body = (first (args)) in let restart_specs = (rest (args)) in let restarts = (List (List.map (fun spec -> (List [(if sx_truthy ((symbol_p ((first (spec))))) then (symbol_name ((first (spec)))) else (first (spec))); (nth (spec) ((Number 1.0))); (nth (spec) ((Number 2.0)))])) (sx_to_list restart_specs))) in (make_cek_state (body) (env) ((kont_push ((make_restart_frame (restarts) ((List [])) (env))) (kont)))))
|
|
|
|
(* step-sf-signal *)
|
|
and step_sf_signal args env kont =
|
|
(let condition = (trampoline ((eval_expr ((first (args))) (env)))) in let handler_fn = (kont_find_handler (kont) (condition)) in (if sx_truthy ((is_nil (handler_fn))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Unhandled condition: "); (inspect (condition))]))))) else (continue_with_call (handler_fn) ((List [condition])) (env) ((List [condition])) ((kont_push ((make_signal_return_frame (env) (kont))) (kont))))))
|
|
|
|
(* step-sf-invoke-restart *)
|
|
and step_sf_invoke_restart args env kont =
|
|
(let restart_name = (let rn = (if sx_truthy ((symbol_p ((first (args))))) then (symbol_name ((first (args)))) else (trampoline ((eval_expr ((first (args))) (env))))) in (if sx_truthy ((symbol_p (rn))) then (symbol_name (rn)) else rn)) in let restart_arg = (if sx_truthy ((prim_call ">=" [(len (args)); (Number 2.0)])) then (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) else Nil) in let found = (kont_find_restart (kont) (restart_name)) in (if sx_truthy ((is_nil (found))) then (raise (Eval_error (value_to_str (String (sx_str [(String "No restart named: "); (inspect (restart_name))]))))) else (let entry = (first (found)) in let restart_frame = (nth (found) ((Number 1.0))) in let rest_kont = (nth (found) ((Number 2.0))) in (let params = (nth (entry) ((Number 1.0))) in let body = (nth (entry) ((Number 2.0))) in let restart_env = (env_extend ((get (restart_frame) ((String "env"))))) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((empty_p (params))))))) then (env_bind restart_env (sx_to_string (first (params))) restart_arg) else Nil)) in (make_cek_state (body) (restart_env) (rest_kont)))))))
|
|
|
|
(* step-sf-if *)
|
|
and step_sf_if args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_if_frame ((nth (args) ((Number 1.0)))) ((if sx_truthy ((prim_call ">" [(len (args)); (Number 2.0)])) then (nth (args) ((Number 2.0))) else Nil)) (env))) (kont))))
|
|
|
|
(* step-sf-when *)
|
|
and step_sf_when args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_when_frame ((rest (args))) (env))) (kont))))
|
|
|
|
(* step-sf-begin *)
|
|
and step_sf_begin args env kont =
|
|
(if sx_truthy ((empty_p (args))) then (make_cek_value (Nil) (env) (kont)) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (make_cek_state ((first (args))) (env) (kont)) else (make_cek_state ((first (args))) (env) ((kont_push ((make_begin_frame ((rest (args))) (env))) (kont))))))
|
|
|
|
(* step-sf-let *)
|
|
and step_sf_let args env kont =
|
|
let pairs = ref Nil in (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (make_cek_value ((sf_named_let (args) (env))) (env) (kont)) else (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in (if sx_truthy ((empty_p (bindings))) then (step_sf_begin (body) (local) (kont)) else (let first_binding = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (first (bindings)) else (List [(first (bindings)); (nth (bindings) ((Number 1.0)))])) in let rest_bindings = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (rest (bindings)) else (let pairs = ref ((List [])) in (let () = ignore ((List.fold_left (fun _acc i -> (pairs := sx_append_b !pairs (List [(nth (bindings) ((prim_call "*" [i; (Number 2.0)]))); (nth (bindings) ((prim_call "inc" [(prim_call "*" [i; (Number 2.0)])])))]); Nil)) Nil (sx_to_list (prim_call "range" [(Number 1.0); (prim_call "/" [(len (bindings)); (Number 2.0)])])))) in !pairs))) in (let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (first_binding)))); (String "symbol")])) then (symbol_name ((first (first_binding)))) else (first (first_binding))) in (make_cek_state ((nth (first_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) (rest_bindings) (body) (local))) (kont)))))))))
|
|
|
|
(* step-sf-define *)
|
|
and step_sf_define args env kont =
|
|
(let name_sym = (first (args)) in let has_effects = (let _and = (prim_call ">=" [(len (args)); (Number 4.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (args) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (args) ((Number 1.0))))); (String "effects")]))) in let val_idx = (if sx_truthy ((let _and = (prim_call ">=" [(len (args)); (Number 4.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (args) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (args) ((Number 1.0))))); (String "effects")])))) then (Number 3.0) else (Number 1.0)) in let effect_list = (if sx_truthy ((let _and = (prim_call ">=" [(len (args)); (Number 4.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (args) ((Number 1.0))))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((nth (args) ((Number 1.0))))); (String "effects")])))) then (nth (args) ((Number 2.0))) else Nil) in (make_cek_state ((nth (args) (val_idx))) (env) ((kont_push ((make_define_frame ((symbol_name (name_sym))) (env) (has_effects) (effect_list))) (kont)))))
|
|
|
|
(* step-sf-set! *)
|
|
and step_sf_set_b args env kont =
|
|
(make_cek_state ((nth (args) ((Number 1.0)))) (env) ((kont_push ((make_set_frame ((symbol_name ((first (args))))) (env))) (kont))))
|
|
|
|
(* step-sf-and *)
|
|
and step_sf_and args env kont =
|
|
(if sx_truthy ((empty_p (args))) then (make_cek_value ((Bool true)) (env) (kont)) else (make_cek_state ((first (args))) (env) ((kont_push ((make_and_frame ((rest (args))) (env))) (kont)))))
|
|
|
|
(* step-sf-or *)
|
|
and step_sf_or args env kont =
|
|
(if sx_truthy ((empty_p (args))) then (make_cek_value ((Bool false)) (env) (kont)) else (make_cek_state ((first (args))) (env) ((kont_push ((make_or_frame ((rest (args))) (env))) (kont)))))
|
|
|
|
(* step-sf-cond *)
|
|
and step_sf_cond args env kont =
|
|
(let scheme_p = (cond_scheme_p (args)) in (if sx_truthy (scheme_p) then (if sx_truthy ((empty_p (args))) then (make_cek_value (Nil) (env) (kont)) else (let clause = (first (args)) in let test = (first (clause)) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state ((nth (clause) ((Number 1.0)))) (env) (kont)) else (make_cek_state (test) (env) ((kont_push ((make_cond_frame (args) (env) ((Bool true)))) (kont))))))) else (if sx_truthy ((prim_call "<" [(len (args)); (Number 2.0)])) then (make_cek_value (Nil) (env) (kont)) else (let test = (first (args)) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state ((nth (args) ((Number 1.0)))) (env) (kont)) else (make_cek_state (test) (env) ((kont_push ((make_cond_frame (args) (env) ((Bool false)))) (kont)))))))))
|
|
|
|
(* step-sf-thread-first *)
|
|
and step_sf_thread_first args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_thread_frame ((rest (args))) (env) ((String "first")) (Nil))) (kont))))
|
|
|
|
(* step-sf-thread-last *)
|
|
and step_sf_thread_last args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_thread_frame ((rest (args))) (env) ((String "last")) (Nil))) (kont))))
|
|
|
|
(* step-sf-thread-as *)
|
|
and step_sf_thread_as args env kont =
|
|
(let init = (first (args)) in let name = (nth (args) ((Number 1.0))) in let forms = (rest ((rest (args)))) in (make_cek_state (init) (env) ((kont_push ((make_thread_frame (forms) (env) ((String "as")) (name))) (kont)))))
|
|
|
|
(* step-sf-lambda *)
|
|
and step_sf_lambda args env kont =
|
|
(make_cek_value ((sf_lambda (args) (env))) (env) (kont))
|
|
|
|
(* step-sf-scope *)
|
|
and step_sf_scope args env kont =
|
|
(let name = (trampoline ((eval_expr ((first (args))) (env)))) in let rest_args = (prim_call "slice" [args; (Number 1.0)]) in let val' = ref (Nil) in let body = ref (Nil) in (let () = ignore ((if sx_truthy ((let _and = (prim_call ">=" [(len (rest_args)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (rest_args)))); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name ((first (rest_args)))); (String "value")])))) then (let () = ignore ((val' := (trampoline ((eval_expr ((nth (rest_args) ((Number 1.0)))) (env)))); Nil)) in (body := (prim_call "slice" [rest_args; (Number 2.0)]); Nil)) else (body := rest_args; Nil))) in (if sx_truthy ((empty_p (!body))) then (make_cek_value (Nil) (env) (kont)) else (make_cek_state ((first (!body))) (env) ((kont_push ((make_scope_acc_frame (name) (!val') ((rest (!body))) (env))) (kont)))))))
|
|
|
|
(* step-sf-provide *)
|
|
and step_sf_provide args env kont =
|
|
(let name = (trampoline ((eval_expr ((first (args))) (env)))) in let val' = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in let body = (prim_call "slice" [args; (Number 2.0)]) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (env) (kont)) else (make_cek_state ((first (body))) (env) ((kont_push ((make_provide_frame (name) (val') ((rest (body))) (env))) (kont))))))
|
|
|
|
(* step-sf-context *)
|
|
and step_sf_context args env kont =
|
|
(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 (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (if sx_truthy ((env_has (env) ((String "context")))) then (sx_apply (env_get (env) ((String "context"))) (List [name; default_val])) else default_val))) (env) (kont)))
|
|
|
|
(* step-sf-emit *)
|
|
and step_sf_emit args env kont =
|
|
(let name = (trampoline ((eval_expr ((first (args))) (env)))) in let val' = (trampoline ((eval_expr ((nth (args) ((Number 1.0)))) (env)))) in let frame = (kont_find_scope_acc (kont) (name)) in (if sx_truthy (frame) then (let () = ignore ((sx_dict_set_b frame (String "emitted") (prim_call "append" [(get (frame) ((String "emitted"))); (List [val'])]))) in (make_cek_value (Nil) (env) (kont))) else (let () = ignore ((if sx_truthy ((env_has (env) ((String "scope-emit!")))) then (sx_apply (env_get (env) ((String "scope-emit!"))) (List [name; val'])) else Nil)) in (make_cek_value (Nil) (env) (kont)))))
|
|
|
|
(* step-sf-emitted *)
|
|
and step_sf_emitted args env kont =
|
|
(let name = (trampoline ((eval_expr ((first (args))) (env)))) in let frame = (kont_find_scope_acc (kont) (name)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "emitted"))) else (if sx_truthy ((env_has (env) ((String "emitted")))) then (sx_apply (env_get (env) ((String "emitted"))) (List [name])) else (List [])))) (env) (kont)))
|
|
|
|
(* step-sf-reset *)
|
|
and step_sf_reset args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_reset_frame (env))) (kont))))
|
|
|
|
(* step-sf-shift *)
|
|
and step_sf_shift args env kont =
|
|
(let k_name = (symbol_name ((first (args)))) in let body = (nth (args) ((Number 1.0))) in let captured_result = (kont_capture_to_reset (kont)) in let captured = (first (captured_result)) in let rest_kont = (nth (captured_result) ((Number 1.0))) in (let k = (make_cek_continuation (captured) (rest_kont)) in (let shift_env = (env_extend (env)) in (let () = ignore ((env_bind shift_env (sx_to_string k_name) k)) in (make_cek_state (body) (shift_env) (rest_kont))))))
|
|
|
|
(* step-sf-deref *)
|
|
and step_sf_deref args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_deref_frame (env))) (kont))))
|
|
|
|
(* cek-call *)
|
|
and cek_call f args =
|
|
(let a = (if sx_truthy ((is_nil (args))) then (List []) else args) in (if sx_truthy ((is_nil (f))) then Nil else (if sx_truthy ((let _or = (is_lambda (f)) in if sx_truthy _or then _or else (is_callable (f)))) then (cek_run ((continue_with_call (f) (a) ((make_env ())) (a) ((List []))))) else Nil)))
|
|
|
|
(* reactive-shift-deref *)
|
|
and reactive_shift_deref sig' env kont =
|
|
(let scan_result = (kont_capture_to_reactive_reset (kont)) in let captured_frames = (first (scan_result)) in let reset_frame = (nth (scan_result) ((Number 1.0))) in let remaining_kont = (nth (scan_result) ((Number 2.0))) in let update_fn = (get (reset_frame) ((String "update-fn"))) in (let sub_disposers = ref ((List [])) in (let subscriber = (NativeFn ("\206\187", fun _args -> (fun () -> let sub_disposers = ref Nil in (let () = ignore ((List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil)) in (let () = ignore ((sub_disposers := (List []); Nil)) in (let new_reset = (make_reactive_reset_frame (env) (update_fn) ((Bool false))) in let new_kont = (prim_call "concat" [captured_frames; (List [new_reset]); remaining_kont]) in (with_island_scope ((NativeFn ("\206\187", fun _args -> match _args with [d] -> (fun d -> let sub_disposers = ref Nil in (sub_disposers := sx_append_b !sub_disposers d; Nil)) d | _ -> Nil))) ((NativeFn ("\206\187", fun _args -> (fun () -> (cek_run ((make_cek_value ((signal_value (sig'))) (env) (new_kont))))) ())))))))) ())) in (let () = ignore ((signal_add_sub_b (sig') (subscriber))) in (let () = ignore ((register_in_scope ((NativeFn ("\206\187", fun _args -> (fun () -> (let () = ignore ((signal_remove_sub_b (sig') (subscriber))) in (List.iter (fun d -> ignore ((cek_call (d) (Nil)))) (sx_to_list !sub_disposers); Nil))) ()))))) in (let initial_kont = (prim_call "concat" [captured_frames; (List [reset_frame]); remaining_kont]) in (make_cek_value ((signal_value (sig'))) (env) (initial_kont))))))))
|
|
|
|
(* step-eval-call *)
|
|
and step_eval_call head args env kont =
|
|
(let hname = (if sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])) then (symbol_name (head)) else Nil) in (make_cek_state (head) (env) ((kont_push ((make_arg_frame (Nil) ((List [])) (args) (env) (args) (hname))) (kont)))))
|
|
|
|
(* ho-form-name? *)
|
|
and ho_form_name_p name =
|
|
(let _or = (prim_call "=" [name; (String "map")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "map-indexed")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "filter")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "reduce")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "some")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [name; (String "every?")]) in if sx_truthy _or then _or else (prim_call "=" [name; (String "for-each")])))))))
|
|
|
|
(* ho-fn? *)
|
|
and ho_fn_p v =
|
|
(let _or = (is_callable (v)) in if sx_truthy _or then _or else (is_lambda (v)))
|
|
|
|
(* ho-swap-args *)
|
|
and ho_swap_args ho_type evaled =
|
|
(if sx_truthy ((prim_call "=" [ho_type; (String "reduce")])) then (let a = (first (evaled)) in let b = (nth (evaled) ((Number 1.0))) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((ho_fn_p (a)))))) in if not (sx_truthy _and) then _and else (ho_fn_p (b)))) then (List [b; (nth (evaled) ((Number 2.0))); a]) else evaled)) else (let a = (first (evaled)) in let b = (nth (evaled) ((Number 1.0))) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((ho_fn_p (a)))))) in if not (sx_truthy _and) then _and else (ho_fn_p (b)))) then (List [b; a]) else evaled)))
|
|
|
|
(* ho-setup-dispatch *)
|
|
and ho_setup_dispatch ho_type evaled env kont =
|
|
(let ordered = (ho_swap_args (ho_type) (evaled)) in (let f = (first (ordered)) in (let _match_val = ho_type in (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (if sx_truthy ((prim_call ">" [(len (ordered)); (Number 2.0)])) then (let colls = (rest (ordered)) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list colls)))) then (make_cek_value ((List [])) (env) (kont)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list colls))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list colls))) in (continue_with_call (f) (heads) (env) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) ((List [])) (env))) (kont))))))) else (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_map_frame (f) ((rest (coll))) ((List [])) (env))) (kont))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(Number 0.0); (first (coll))])) (env) ((List [])) ((kont_push ((make_map_indexed_frame (f) ((rest (coll))) ((List [])) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (coll))) ((List [])) ((first (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let init = (nth (ordered) ((Number 1.0))) in let coll = (nth (ordered) ((Number 2.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (init) (env) (kont)) else (continue_with_call (f) ((List [init; (first (coll))])) (env) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool false)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_some_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool true)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_every_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (Nil) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (coll))) (env))) (kont)))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown HO type: "); ho_type])))))))))))))))
|
|
|
|
(* step-ho-map *)
|
|
and step_ho_map args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "map")) ((rest (args))) ((List [])) (env))) (kont))))
|
|
|
|
(* step-ho-map-indexed *)
|
|
and step_ho_map_indexed args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "map-indexed")) ((rest (args))) ((List [])) (env))) (kont))))
|
|
|
|
(* step-ho-filter *)
|
|
and step_ho_filter args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "filter")) ((rest (args))) ((List [])) (env))) (kont))))
|
|
|
|
(* step-ho-reduce *)
|
|
and step_ho_reduce args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "reduce")) ((rest (args))) ((List [])) (env))) (kont))))
|
|
|
|
(* step-ho-some *)
|
|
and step_ho_some args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "some")) ((rest (args))) ((List [])) (env))) (kont))))
|
|
|
|
(* step-ho-every *)
|
|
and step_ho_every args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "every")) ((rest (args))) ((List [])) (env))) (kont))))
|
|
|
|
(* step-ho-for-each *)
|
|
and step_ho_for_each args env kont =
|
|
(make_cek_state ((first (args))) (env) ((kont_push ((make_ho_setup_frame ((String "for-each")) ((rest (args))) ((List [])) (env))) (kont))))
|
|
|
|
(* step-continue *)
|
|
and step_continue state =
|
|
let _last_error_kont_ = ref Nil in (let value = (cek_value (state)) in let env = (cek_env (state)) in let kont = (cek_kont (state)) in (if sx_truthy ((kont_empty_p (kont))) then state else (let frame = (kont_top (kont)) in let rest_k = (kont_pop (kont)) in let ft = (frame_type (frame)) in (let _match_val = ft in (if sx_truthy ((prim_call "=" [_match_val; (String "if")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (make_cek_state ((get (frame) ((String "then")))) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((is_nil ((get (frame) ((String "else")))))) then (make_cek_value (Nil) (env) (rest_k)) else (make_cek_state ((get (frame) ((String "else")))) ((get (frame) ((String "env")))) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "when")])) then (if sx_truthy ((let _and = value in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil (value)))))))) then (let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (body))) then (make_cek_value (Nil) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (make_cek_state ((first (body))) (fenv) (rest_k)) else (make_cek_state ((first (body))) (fenv) ((kont_push ((make_begin_frame ((rest (body))) (fenv))) (rest_k))))))) else (make_cek_value (Nil) (env) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "begin")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then (make_cek_state ((first (remaining))) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_begin_frame ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "let")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let body = (get (frame) ((String "body"))) in let local = (get (frame) ((String "env"))) in (let () = ignore ((env_bind local (sx_to_string name) value)) in (if sx_truthy ((empty_p (remaining))) then (step_sf_begin (body) (local) (rest_k)) else (let next_binding = (first (remaining)) in let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (next_binding)))); (String "symbol")])) then (symbol_name ((first (next_binding)))) else (first (next_binding))) in (make_cek_state ((nth (next_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) ((rest (remaining))) (body) (local))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "define")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in let has_effects = (get (frame) ((String "has-effects"))) in let effect_list = (get (frame) ((String "effect-list"))) in (let () = ignore ((if sx_truthy ((let _and = (is_lambda (value)) in if not (sx_truthy _and) then _and else (is_nil ((lambda_name (value)))))) then (set_lambda_name value (sx_to_string name)) else Nil)) in (let () = ignore ((env_bind fenv (sx_to_string name) value)) in (let () = ignore ((if sx_truthy (has_effects) then (let effect_names = (List (List.map (fun e -> (if sx_truthy ((prim_call "=" [(type_of (e)); (String "symbol")])) then (symbol_name (e)) else e)) (sx_to_list effect_list))) in let effect_anns = (if sx_truthy ((env_has (fenv) ((String "*effect-annotations*")))) then (env_get (fenv) ((String "*effect-annotations*"))) else (Dict (Hashtbl.create 0))) in (let () = ignore ((sx_dict_set_b effect_anns name effect_names)) in (env_bind fenv (sx_to_string (String "*effect-annotations*")) effect_anns))) else Nil)) in (make_cek_value (value) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "set")])) then (let name = (get (frame) ((String "name"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((env_set fenv (sx_to_string name) value)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "and")])) then (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_and_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "or")])) then (if sx_truthy (value) then (make_cek_value (value) (env) (rest_k)) else (let remaining = (get (frame) ((String "remaining"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (env) (rest_k)) else (make_cek_state ((first (remaining))) ((get (frame) ((String "env")))) ((if sx_truthy ((prim_call "=" [(len (remaining)); (Number 1.0)])) then rest_k else (kont_push ((make_or_frame ((rest (remaining))) ((get (frame) ((String "env")))))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let scheme_p = (get (frame) ((String "scheme"))) in (if sx_truthy (scheme_p) then (if sx_truthy (value) then (let clause = (first (remaining)) in (if sx_truthy ((let _and = (prim_call ">" [(len (clause)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((nth (clause) ((Number 1.0))))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((nth (clause) ((Number 1.0))))); (String "=>")])))) then (make_cek_state ((nth (clause) ((Number 2.0)))) (fenv) ((kont_push ((make_cond_arrow_frame (value) (fenv))) (rest_k)))) else (make_cek_state ((nth (clause) ((Number 1.0)))) (fenv) (rest_k)))) else (let next_clauses = (rest (remaining)) in (if sx_truthy ((empty_p (next_clauses))) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_clause = (first (next_clauses)) in let next_test = (first (next_clause)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next_clause) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next_clauses) (fenv) ((Bool true)))) (rest_k))))))))) else (if sx_truthy (value) then (make_cek_state ((nth (remaining) ((Number 1.0)))) (fenv) (rest_k)) else (let next = (prim_call "slice" [remaining; (Number 2.0); (len (remaining))]) in (if sx_truthy ((prim_call "<" [(len (next)); (Number 2.0)])) then (make_cek_value (Nil) (fenv) (rest_k)) else (let next_test = (first (next)) in (if sx_truthy ((is_else_clause (next_test))) then (make_cek_state ((nth (next) ((Number 1.0)))) (fenv) (rest_k)) else (make_cek_state (next_test) (fenv) ((kont_push ((make_cond_frame (next) (fenv) ((Bool false)))) (rest_k))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "case")])) then (let match_val = (get (frame) ((String "match-val"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (match_val))) then (sf_case_step_loop (value) (remaining) (fenv) (rest_k)) else (sf_case_step_loop (match_val) (remaining) (fenv) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "thread")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let mode = (get (frame) ((String "extra"))) in let bind_name = (get (frame) ((String "name"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (let form = (first (remaining)) in let rest_forms = (rest (remaining)) in let new_kont = (if sx_truthy ((empty_p ((rest (remaining))))) then rest_k else (kont_push ((make_thread_frame ((rest (remaining))) (fenv) (mode) (bind_name))) (rest_k))) in (if sx_truthy ((prim_call "=" [mode; (String "as")])) then (let new_env = (env_extend (fenv)) in (let () = ignore ((env_bind new_env (sx_to_string (symbol_name (bind_name))) value)) in (make_cek_state (form) (new_env) (new_kont)))) else (if sx_truthy ((let _and = (prim_call "=" [(type_of (form)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (form)))))) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (form)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (ho_form_name_p ((symbol_name ((first (form)))))))))) then (make_cek_state ((cons ((first (form))) ((cons ((List [(Symbol "quote"); value])) ((rest (form))))))) (fenv) (new_kont)) else (if sx_truthy ((prim_call "=" [mode; (String "last")])) then (let result' = (thread_insert_arg_last (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv) (mode) (bind_name))) (rest_k)))))) else (let result' = (thread_insert_arg (form) (value) (fenv)) in (if sx_truthy ((empty_p (rest_forms))) then (make_cek_value (result') (fenv) (rest_k)) else (make_cek_value (result') (fenv) ((kont_push ((make_thread_frame (rest_forms) (fenv) (mode) (bind_name))) (rest_k)))))))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "arg")])) then (let f = (get (frame) ((String "f"))) in let evaled = (get (frame) ((String "evaled"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in let raw_args = (get (frame) ((String "raw-args"))) in let hname = (get (frame) ((String "head-name"))) in (if sx_truthy ((is_nil (f))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) ((List []))) else Nil)) in (if sx_truthy ((empty_p (remaining))) then (continue_with_call (value) ((List [])) (fenv) (raw_args) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (value) ((List [])) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))) else (let new_evaled = (prim_call "append" [evaled; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else hname)) then (strict_check_args (hname) (new_evaled)) else Nil)) in (continue_with_call (f) (new_evaled) (fenv) (raw_args) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_arg_frame (f) (new_evaled) ((rest (remaining))) (fenv) (raw_args) (hname))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "dict")])) then (let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let fenv = (get (frame) ((String "env"))) in (let last_result = (last (results)) in let completed = (prim_call "append" [(prim_call "slice" [results; (Number 0.0); (prim_call "dec" [(len (results))])]); (List [(List [(first (last_result)); value])])]) in (if sx_truthy ((empty_p (remaining))) then (let d = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun pair -> ignore ((sx_dict_set_b d (first (pair)) (nth (pair) ((Number 1.0)))))) (sx_to_list completed); Nil)) in (make_cek_value (d) (fenv) (rest_k)))) else (let next_entry = (first (remaining)) in (make_cek_state ((nth (next_entry) ((Number 1.0)))) (fenv) ((kont_push ((make_dict_frame ((rest (remaining))) ((prim_call "append" [completed; (List [(List [(first (next_entry))])])])) (fenv))) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "ho-setup")])) then (let ho_type = (get (frame) ((String "ho-type"))) in let remaining = (get (frame) ((String "remaining"))) in let evaled = (prim_call "append" [(get (frame) ((String "evaled"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (ho_setup_dispatch (ho_type) (evaled) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_ho_setup_frame (ho_type) ((rest (remaining))) (evaled) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reset")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "deref")])) then (let val' = value in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy ((is_signal (val'))))))) then (make_cek_value (val') (fenv) (rest_k)) else (if sx_truthy ((has_reactive_reset_frame_p (rest_k))) then (reactive_shift_deref (val') (fenv) (rest_k)) else (let () = ignore ((let ctx = (sx_context ((String "sx-reactive")) (Nil)) in (if sx_truthy (ctx) then (let dep_list = ref ((get (ctx) ((String "deps")))) in let notify_fn = (get (ctx) ((String "notify"))) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "contains?" [!dep_list; val'])))))) then (let () = ignore ((dep_list := sx_append_b !dep_list val'; Nil)) in (signal_add_sub_b (val') (notify_fn))) else Nil)) else Nil))) in (make_cek_value ((signal_value (val'))) (fenv) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reactive-reset")])) then (let update_fn = (get (frame) ((String "update-fn"))) in let first_p = (get (frame) ((String "first-render"))) in (let () = ignore ((if sx_truthy ((let _and = update_fn in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy (first_p)))))) then (cek_call (update_fn) ((List [value]))) else Nil)) in (make_cek_value (value) (env) (rest_k)))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope")])) then (let name = (get (frame) ((String "name"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (let () = ignore ((scope_pop (name))) in (make_cek_value (value) (fenv) (rest_k))) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_scope_frame (name) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "provide")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_provide_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "scope-acc")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((let new_frame = (make_scope_acc_frame ((get (frame) ((String "name")))) ((get (frame) ((String "value")))) ((rest (remaining))) (fenv)) in (let () = ignore ((sx_dict_set_b new_frame (String "emitted") (get (frame) ((String "emitted"))))) in new_frame))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let indexed = (get (frame) ((String "indexed"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (prim_call "append" [results; (List [value])]) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let call_args = (if sx_truthy (indexed) then (List [(len (new_results)); (first (remaining))]) else (List [(first (remaining))])) in let next_frame = (if sx_truthy (indexed) then (make_map_indexed_frame (f) ((rest (remaining))) (new_results) (fenv)) else (make_map_frame (f) ((rest (remaining))) (new_results) (fenv))) in (continue_with_call (f) (call_args) (fenv) ((List [])) ((kont_push (next_frame) (rest_k)))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let results = (get (frame) ((String "results"))) in let current_item = (get (frame) ((String "current-item"))) in let fenv = (get (frame) ((String "env"))) in (let new_results = (if sx_truthy (value) then (prim_call "append" [results; (List [current_item])]) else results) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (new_results) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (remaining))) (new_results) ((first (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (continue_with_call (f) ((List [value; (first (remaining))])) (fenv) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (Nil) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy (value) then (make_cek_value (value) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_some_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (not (sx_truthy (value))))) then (make_cek_value ((Bool false)) (fenv) (rest_k)) else (if sx_truthy ((empty_p (remaining))) then (make_cek_value ((Bool true)) (fenv) (rest_k)) else (continue_with_call (f) ((List [(first (remaining))])) (fenv) ((List [])) ((kont_push ((make_every_frame (f) ((rest (remaining))) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "handler")])) then (let remaining = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((empty_p (remaining))) then (make_cek_value (value) (fenv) (rest_k)) else (make_cek_state ((first (remaining))) (fenv) ((kont_push ((make_handler_frame ((get (frame) ((String "f")))) ((rest (remaining))) (fenv))) (rest_k)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "restart")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "signal-return")])) then (let saved_kont = (get (frame) ((String "saved-kont"))) in (make_cek_value (value) ((get (frame) ((String "env")))) (saved_kont))) else (if sx_truthy ((prim_call "=" [_match_val; (String "comp-trace")])) then (make_cek_value (value) (env) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "cond-arrow")])) then (let test_value = (get (frame) ((String "match-val"))) in let fenv = (get (frame) ((String "env"))) in (continue_with_call (value) ((List [test_value])) (fenv) ((List [test_value])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-eval")])) then (let condition = value in let fenv = (get (frame) ((String "env"))) in let continuable_p = (get (frame) ((String "scheme"))) in let handler_fn = (kont_find_handler (rest_k) (condition)) in (if sx_truthy ((is_nil (handler_fn))) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String (sx_str [(String "Unhandled exception: "); (inspect (condition))]))))) else (continue_with_call (handler_fn) ((List [condition])) (fenv) ((List [condition])) ((if sx_truthy (continuable_p) then (kont_push ((make_signal_return_frame (fenv) (rest_k))) (rest_k)) else (kont_push ((make_raise_guard_frame (fenv) (rest_k))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "raise-guard")])) then (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (host_error ((String "exception handler returned from non-continuable raise")))) else (if sx_truthy ((prim_call "=" [_match_val; (String "multi-map")])) then (let f = (get (frame) ((String "f"))) in let remaining = (get (frame) ((String "remaining"))) in let new_results = (prim_call "append" [(get (frame) ((String "results"))); (List [value])]) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list remaining)))) then (make_cek_value (new_results) (fenv) (rest_k)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list remaining))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list remaining))) in (continue_with_call (f) (heads) (fenv) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) (new_results) (fenv))) (rest_k))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "callcc")])) then (let k = (make_callcc_continuation (rest_k)) in (continue_with_call (value) ((List [k])) ((get (frame) ((String "env")))) ((List [k])) (rest_k))) else (if sx_truthy ((prim_call "=" [_match_val; (String "vm-resume")])) then (let resume_fn = (get (frame) ((String "f"))) in (let result' = (sx_apply resume_fn (List [value])) in (if sx_truthy ((let _and = (dict_p (result')) in if not (sx_truthy _and) then _and else (get (result') ((String "__vm_suspended"))))) then (make_cek_suspended ((get (result') ((String "request")))) ((get (frame) ((String "env")))) ((kont_push ((make_vm_resume_frame ((get (result') ((String "resume")))) ((get (frame) ((String "env")))))) (rest_k)))) else (make_cek_value (result') ((get (frame) ((String "env")))) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "perform")])) then (make_cek_suspended (value) ((get (frame) ((String "env")))) (rest_k)) else (if sx_truthy ((prim_call "=" [_match_val; (String "import")])) then (let import_set = (get (frame) ((String "args"))) in let remaining_sets = (get (frame) ((String "remaining"))) in let fenv = (get (frame) ((String "env"))) in (let () = ignore ((bind_import_set (import_set) (fenv))) in (if sx_truthy ((empty_p (remaining_sets))) then (make_cek_value (Nil) (fenv) (rest_k)) else (step_sf_import (remaining_sets) (fenv) (rest_k))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "parameterize")])) then (let remaining = (get (frame) ((String "remaining"))) in let current_param = (get (frame) ((String "f"))) in let results = (get (frame) ((String "results"))) in let body = (get (frame) ((String "body"))) in let fenv = (get (frame) ((String "env"))) in (if sx_truthy ((is_nil (current_param))) then (let param_obj = value in let val_expr = (nth ((first (remaining))) ((Number 1.0))) in (make_cek_state (val_expr) (fenv) ((kont_push ((make_parameterize_frame (remaining) (param_obj) (results) (body) (fenv))) (rest_k))))) else (let converted_val = value in let new_results = (prim_call "append" [results; (List [(List [(parameter_uid (current_param)); converted_val])])]) in let rest_bindings = (rest (remaining)) in (if sx_truthy ((empty_p (rest_bindings))) then (let body_expr = (if sx_truthy ((prim_call "=" [(len (body)); (Number 1.0)])) then (first (body)) else (cons ((Symbol "begin")) (body))) in let provide_kont = (kont_push_provides (new_results) (fenv) (rest_k)) in (make_cek_state (body_expr) (fenv) (provide_kont))) else (make_cek_state ((first ((first (rest_bindings))))) (fenv) ((kont_push ((make_parameterize_frame (rest_bindings) (Nil) (new_results) (body) (fenv))) (rest_k)))))))) else (let () = ignore ((_last_error_kont_ref := rest_k; Nil)) in (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown frame type: "); ft])))))))))))))))))))))))))))))))))))))))))))))))))
|
|
|
|
(* continue-with-call *)
|
|
and continue_with_call f args env raw_args kont =
|
|
(if sx_truthy ((parameter_p (f))) then (let uid = (parameter_uid (f)) in let frame = (kont_find_provide (kont) (uid)) in (make_cek_value ((if sx_truthy (frame) then (get (frame) ((String "value"))) else (parameter_default (f)))) (env) (kont))) else (if sx_truthy ((callcc_continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let captured = (callcc_continuation_data (f)) in (make_cek_value (arg) (env) (captured))) else (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (make_cek_value ((sx_apply f args)) (env) (kont)) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (let () = ignore ((if sx_truthy ((Bool (not (sx_truthy ((bind_lambda_params (params) (args) (local))))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else Nil)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil))) else Nil)) in (let jit_result = (jit_try_call (f) (args)) in (if sx_truthy ((is_nil (jit_result))) then (make_cek_state ((lambda_body (f))) (local) (kont)) else (if sx_truthy ((let _and = (dict_p (jit_result)) in if not (sx_truthy _and) then _and else (get (jit_result) ((String "__vm_suspended"))))) then (make_cek_suspended ((get (jit_result) ((String "request")))) (env) ((kont_push ((make_vm_resume_frame ((get (jit_result) ((String "resume")))) (env))) (kont)))) else (make_cek_value (jit_result) (local) (kont))))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) ((kont_push ((make_comp_trace_frame ((component_name (f))) ((component_file (f))))) (kont))))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))])))))))))))
|
|
|
|
(* sf-case-step-loop *)
|
|
and sf_case_step_loop match_val clauses env kont =
|
|
(if sx_truthy ((prim_call "<" [(len (clauses)); (Number 2.0)])) then (make_cek_value (Nil) (env) (kont)) else (let test = (first (clauses)) in let body = (nth (clauses) ((Number 1.0))) in (if sx_truthy ((is_else_clause (test))) then (make_cek_state (body) (env) (kont)) else (let test_val = (trampoline ((eval_expr (test) (env)))) in (if sx_truthy ((prim_call "=" [match_val; test_val])) then (make_cek_state (body) (env) (kont)) else (sf_case_step_loop (match_val) ((prim_call "slice" [clauses; (Number 2.0)])) (env) (kont)))))))
|
|
|
|
(* eval-expr-cek *)
|
|
and eval_expr_cek expr env =
|
|
(cek_run ((make_cek_state (expr) (env) ((List [])))))
|
|
|
|
(* trampoline-cek *)
|
|
and trampoline_cek val' =
|
|
(if sx_truthy ((is_thunk (val'))) then (eval_expr_cek ((thunk_expr (val'))) ((thunk_env (val')))) else val')
|
|
|
|
(* eval-expr *)
|
|
and eval_expr expr env =
|
|
(cek_run ((make_cek_state (expr) (env) ((List [])))))
|
|
|
|
|
|
(* Wire up trampoline to resolve thunks via the CEK machine *)
|
|
let () = trampoline_fn := (fun v ->
|
|
match v with
|
|
| Thunk (expr, env) -> eval_expr expr (Env env)
|
|
| _ -> v)
|
|
|
|
(* Wire up the primitives trampoline so call_any in HO forms resolves Thunks *)
|
|
let () = Sx_primitives._sx_trampoline_fn := !trampoline_fn
|
|
|
|
(* Override recursive cek_run with iterative loop.
|
|
On error, capture the kont from the last state for comp-trace. *)
|
|
let cek_run_iterative state =
|
|
let s = ref state in
|
|
(try
|
|
while not (match cek_terminal_p !s with Bool true -> true | _ -> false)
|
|
&& not (match cek_suspended_p !s with Bool true -> true | _ -> false) do
|
|
s := cek_step !s
|
|
done;
|
|
(match cek_suspended_p !s with
|
|
| Bool true -> raise (Eval_error "IO suspension in non-IO context")
|
|
| _ -> cek_value !s)
|
|
with Eval_error msg ->
|
|
_last_error_kont_ref := cek_kont !s;
|
|
raise (Eval_error msg))
|
|
|
|
(* Collect component trace from a kont value *)
|
|
let collect_comp_trace kont =
|
|
let trace = ref [] in
|
|
let k = ref kont in
|
|
while (match !k with List (_::_) -> true | _ -> false) do
|
|
(match !k with
|
|
| List (frame :: rest) ->
|
|
(match frame with
|
|
| CekFrame f when f.cf_type = "comp-trace" ->
|
|
let name = match f.cf_name with String s -> s | _ -> "?" in
|
|
let file = match f.cf_env with String s -> s | Nil -> "" | _ -> "" in
|
|
trace := (name, file) :: !trace
|
|
| Dict d when (match Hashtbl.find_opt d "type" with Some (String "comp-trace") -> true | _ -> false) ->
|
|
let name = match Hashtbl.find_opt d "name" with Some (String s) -> s | _ -> "?" in
|
|
let file = match Hashtbl.find_opt d "file" with Some (String s) -> s | _ -> "" in
|
|
trace := (name, file) :: !trace
|
|
| _ -> ());
|
|
k := List rest
|
|
| _ -> k := List [])
|
|
done;
|
|
List.rev !trace
|
|
|
|
(* Format a comp-trace into a human-readable string *)
|
|
let format_comp_trace trace =
|
|
match trace with
|
|
| [] -> ""
|
|
| entries ->
|
|
let lines = List.mapi (fun i (name, file) ->
|
|
let prefix = if i = 0 then " in " else " called from " in
|
|
if file = "" then prefix ^ "~" ^ name
|
|
else prefix ^ "~" ^ name ^ " (" ^ file ^ ")"
|
|
) entries in
|
|
"
|
|
" ^ String.concat "
|
|
" lines
|
|
|
|
(* Enhance an error message with component trace *)
|
|
let enhance_error_with_trace msg =
|
|
let trace = collect_comp_trace !_last_error_kont_ref in
|
|
_last_error_kont_ref := Nil;
|
|
msg ^ (format_comp_trace trace)
|
|
|
|
|
|
|