coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
be47a5c1a540bd531d1ff91fb8071057df344549
rose-ash/spec/evaluator.sx
giles e33fbd29e7 Move &rest params into spec, eliminate 9 of 11 bootstrap patches 
evaluator.sx:
- bind-lambda-params: shared &rest detection for call-lambda + continue-with-call
- *last-error-kont* mutable global for error diagnostics

transpiler.sx:
- *last-error-kont* in ml-mutable-globals

bootstrap.py: removed 9 patches (mutable globals ×5, make-env, &rest helper,
call_lambda replacement, cwc_lambda replacement). Only 3 platform-level
patches remain: make_raise_guard_frame injection, cek_run error capture,
JIT hook dispatch.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-04-03 14:37:38 +00:00

2795 lines
87 KiB
Plaintext
Raw Blame History

(define make-cek-state (fn (control env kont) {:control control :env env :kont kont :value nil :phase "eval"}))
(define make-cek-value (fn (value env kont) {:control nil :env env :kont kont :value value :phase "continue"}))
(define
cek-terminal?
(fn
(state)
(and (= (get state "phase") "continue") (empty? (get state "kont")))))
(define cek-control (fn (s) (get s "control")))
(define cek-env (fn (s) (get s "env")))
(define cek-kont (fn (s) (get s "kont")))
(define cek-phase (fn (s) (get s "phase")))
(define cek-value (fn (s) (get s "value")))
(define make-if-frame (fn (then-expr else-expr env) {:else else-expr :env env :type "if" :then then-expr}))
(define make-when-frame (fn (body-exprs env) {:body body-exprs :env env :type "when"}))
(define make-begin-frame (fn (remaining env) {:env env :type "begin" :remaining remaining}))
(define make-let-frame (fn (name remaining body local) {:body body :env local :type "let" :remaining remaining :name name}))
(define make-define-frame (fn (name env has-effects effect-list) {:env env :effect-list effect-list :has-effects has-effects :type "define" :name name}))
(define make-set-frame (fn (name env) {:env env :type "set" :name name}))
(define
make-arg-frame
(fn (f evaled remaining env raw-args head-name) {:env env :head-name (or head-name nil) :evaled evaled :type "arg" :f f :remaining remaining :raw-args raw-args}))
(define make-call-frame (fn (f args env) {:args args :env env :type "call" :f f}))
(define make-cond-frame (fn (remaining env scheme?) {:scheme scheme? :env env :type "cond" :remaining remaining}))
(define make-cond-arrow-frame (fn (test-value env) {:env env :match-val test-value :type "cond-arrow"}))
(define make-case-frame (fn (match-val remaining env) {:match-val match-val :env env :type "case" :remaining remaining}))
(define make-thread-frame (fn (remaining env) {:env env :type "thread" :remaining remaining}))
(define
thread-insert-arg
(fn
(form value fenv)
(if
(= (type-of form) "list")
(eval-expr
(cons (first form) (cons (list (quote quote) value) (rest form)))
fenv)
(eval-expr (list form (list (quote quote) value)) fenv))))
(define make-map-frame (fn (f remaining results env) {:indexed false :env env :results results :type "map" :f f :remaining remaining}))
(define make-map-indexed-frame (fn (f remaining results env) {:indexed true :env env :results results :type "map" :f f :remaining remaining}))
(define make-multi-map-frame (fn (f remaining-lists results env) {:env env :results results :type "multi-map" :f f :remaining remaining-lists}))
(define
make-filter-frame
(fn (f remaining results current-item env) {:current-item current-item :env env :results results :type "filter" :f f :remaining remaining}))
(define make-reduce-frame (fn (f remaining env) {:env env :type "reduce" :f f :remaining remaining}))
(define make-for-each-frame (fn (f remaining env) {:env env :type "for-each" :f f :remaining remaining}))
(define make-some-frame (fn (f remaining env) {:env env :type "some" :f f :remaining remaining}))
(define make-every-frame (fn (f remaining env) {:env env :type "every" :f f :remaining remaining}))
(define make-scope-frame (fn (name remaining env) {:env env :type "scope" :remaining remaining :name name}))
(define make-provide-frame (fn (name value remaining env) {:env env :value value :type "provide" :remaining remaining :name name}))
(define make-scope-acc-frame (fn (name value remaining env) {:env env :value (or value nil) :type "scope-acc" :remaining remaining :emitted (list) :name name}))
(define make-reset-frame (fn (env) {:env env :type "reset"}))
(define make-dict-frame (fn (remaining results env) {:env env :results results :type "dict" :remaining remaining}))
(define make-and-frame (fn (remaining env) {:env env :type "and" :remaining remaining}))
(define make-or-frame (fn (remaining env) {:env env :type "or" :remaining remaining}))
(define
make-dynamic-wind-frame
(fn (phase body-thunk after-thunk env) {:env env :phase phase :after-thunk after-thunk :type "dynamic-wind" :body-thunk body-thunk}))
(define
make-reactive-reset-frame
(fn (env update-fn first-render?) {:first-render first-render? :update-fn update-fn :env env :type "reactive-reset"}))
(define make-callcc-frame (fn (env) {:env env :type "callcc"}))
(define make-deref-frame (fn (env) {:env env :type "deref"}))
(define
make-ho-setup-frame
(fn (ho-type remaining-args evaled-args env) {:ho-type ho-type :env env :evaled evaled-args :type "ho-setup" :remaining remaining-args}))
(define make-comp-trace-frame (fn (name file) {:env file :type "comp-trace" :name name}))
(define
kont-collect-comp-trace
(fn
(kont)
(if
(empty? kont)
(list)
(let
((frame (first kont)))
(if
(= (frame-type frame) "comp-trace")
(cons {:file (get frame "file") :name (get frame "name")} (kont-collect-comp-trace (rest kont)))
(kont-collect-comp-trace (rest kont)))))))
(define make-handler-frame (fn (handlers remaining env) {:env env :type "handler" :f handlers :remaining remaining}))
(define make-restart-frame (fn (restarts remaining env) {:env env :type "restart" :f restarts :remaining remaining}))
(define make-signal-return-frame (fn (env saved-kont) {:env env :type "signal-return" :f saved-kont}))
(define make-raise-eval-frame (fn (env continuable?) {:scheme continuable? :env env :type "raise-eval"}))
(define
find-matching-handler
(fn
(handlers condition)
(if
(empty? handlers)
nil
(let
((pair (first handlers)))
(let
((pred (first pair)) (handler-fn (nth pair 1)))
(if
(cek-call pred (list condition))
handler-fn
(find-matching-handler (rest handlers) condition)))))))
(define
kont-find-handler
(fn
(kont condition)
(if
(empty? kont)
nil
(let
((frame (first kont)))
(if
(= (frame-type frame) "handler")
(let
((match (find-matching-handler (get frame "f") condition)))
(if
(nil? match)
(kont-find-handler (rest kont) condition)
match))
(kont-find-handler (rest kont) condition))))))
(define
find-named-restart
(fn
(restarts name)
(if
(empty? restarts)
nil
(let
((entry (first restarts)))
(if
(= (first entry) name)
entry
(find-named-restart (rest restarts) name))))))
(define
kont-find-restart
(fn
(kont name)
(if
(empty? kont)
nil
(let
((frame (first kont)))
(if
(= (frame-type frame) "restart")
(let
((match (find-named-restart (get frame "f") name)))
(if
(nil? match)
(kont-find-restart (rest kont) name)
(list match frame (rest kont))))
(kont-find-restart (rest kont) name))))))
(define frame-type (fn (f) (get f "type")))
(define kont-push (fn (frame kont) (cons frame kont)))
(define kont-top (fn (kont) (first kont)))
(define kont-pop (fn (kont) (rest kont)))
(define kont-empty? (fn (kont) (empty? kont)))
(define
kont-capture-to-reset
(fn
(kont)
(define
scan
(fn
(k captured)
(if
(empty? k)
(error "shift without enclosing reset")
(let
((frame (first k)))
(if
(or
(= (frame-type frame) "reset")
(= (frame-type frame) "reactive-reset"))
(list captured (rest k))
(scan (rest k) (append captured (list frame))))))))
(scan kont (list))))
(define
kont-find-provide
(fn
(kont name)
(if
(empty? kont)
nil
(let
((frame (first kont)))
(if
(and
(= (frame-type frame) "provide")
(= (get frame "name") name))
frame
(kont-find-provide (rest kont) name))))))
(define
kont-find-scope-acc
(fn
(kont name)
(if
(empty? kont)
nil
(let
((frame (first kont)))
(if
(and
(= (frame-type frame) "scope-acc")
(= (get frame "name") name))
frame
(kont-find-scope-acc (rest kont) name))))))
(define
has-reactive-reset-frame?
(fn
(kont)
(if
(empty? kont)
false
(if
(= (frame-type (first kont)) "reactive-reset")
true
(has-reactive-reset-frame? (rest kont))))))
(define
kont-capture-to-reactive-reset
(fn
(kont)
(define
scan
(fn
(k captured)
(if
(empty? k)
(error "reactive deref without enclosing reactive-reset")
(let
((frame (first k)))
(if
(= (frame-type frame) "reactive-reset")
(list captured frame (rest k))
(scan (rest k) (append captured (list frame))))))))
(scan kont (list))))
(define *custom-special-forms* (dict))
(define
register-special-form!
(fn
((name :as string) handler)
(dict-set! *custom-special-forms* name handler)))
(define *render-check* nil)
(define *render-fn* nil)
(define
trampoline
(fn
((val :as any))
(let
((result val))
(do
(if
(thunk? result)
(trampoline (eval-expr (thunk-expr result) (thunk-env result)))
result)))))
(define *strict* false)
(define set-strict! (fn (val) (set! *strict* val)))
(define *prim-param-types* nil)
(define set-prim-param-types! (fn (types) (set! *prim-param-types* types)))
(define
value-matches-type?
(fn
(val expected-type)
(match
expected-type
("any" true)
("number" (number? val))
("string" (string? val))
("boolean" (boolean? val))
("nil" (nil? val))
("list" (list? val))
("dict" (dict? val))
("lambda" (lambda? val))
("symbol" (= (type-of val) "symbol"))
("keyword" (= (type-of val) "keyword"))
(_
(if
(and (string? expected-type) (ends-with? expected-type "?"))
(or
(nil? val)
(value-matches-type?
val
(slice expected-type 0 (- (string-length expected-type) 1))))
true)))))
(define
strict-check-args
(fn
(name args)
(when
(and *strict* *prim-param-types*)
(let
((spec (get *prim-param-types* name)))
(when
spec
(let
((positional (get spec "positional"))
(rest-type (get spec "rest-type")))
(when
positional
(for-each
(fn
(pair)
(let
((idx (first pair))
(param (nth pair 1))
(p-name (first param))
(p-type (nth param 1)))
(when
(< idx (len args))
(let
((val (nth args idx)))
(when
(not (value-matches-type? val p-type))
(error
(str
"Type error: "
name
" expected "
p-type
" for param "
p-name
", got "
(type-of val)
" ("
(str val)
")")))))))
(map-indexed (fn (i p) (list i p)) positional)))
(when
(and rest-type (> (len args) (len (or positional (list)))))
(for-each
(fn
(pair)
(let
((idx (first pair)) (val (nth pair 1)))
(when
(not (value-matches-type? val rest-type))
(error
(str
"Type error: "
name
" expected "
rest-type
" for rest arg "
idx
", got "
(type-of val)
" ("
(str val)
")")))))
(map-indexed
(fn (i v) (list i v))
(slice args (len (or positional (list)))))))))))))
(define eval-expr (fn (expr (env :as dict)) nil))
(define
bind-lambda-params
(fn
(params args local)
(let
((rest-idx (index-of params "&rest")))
(if
(and (number? rest-idx) (< rest-idx (len params)))
(let
((positional (slice params 0 rest-idx))
(rest-name (nth params (+ rest-idx 1))))
(do
(for-each-indexed
(fn
(i p)
(env-bind! local p (if (< i (len args)) (nth args i) nil)))
positional)
(env-bind!
local
rest-name
(if (> (len args) rest-idx) (slice args rest-idx) (quote ())))
true))
false))))
(define
call-lambda
(fn
((f :as lambda) (args :as list) (caller-env :as dict))
(let
((params (lambda-params f))
(local (env-merge (lambda-closure f) caller-env)))
(when
(not (bind-lambda-params params args local))
(when
(> (len args) (len params))
(error
(str
(or (lambda-name f) "lambda")
" expects "
(len params)
" args, got "
(len args))))
(for-each
(fn (pair) (env-bind! local (first pair) (nth pair 1)))
(zip params args))
(for-each
(fn (p) (env-bind! local p nil))
(slice params (len args))))
(make-thunk (lambda-body f) local))))
(define
call-component
(fn
((comp :as component) (raw-args :as list) (env :as dict))
(let
((parsed (parse-keyword-args raw-args env))
(kwargs (first parsed))
(children (nth parsed 1))
(local (env-merge (component-closure comp) env)))
(for-each
(fn (p) (env-bind! local p (or (dict-get kwargs p) nil)))
(component-params comp))
(when
(component-has-children? comp)
(env-bind! local "children" children))
(make-thunk (component-body comp) local))))
(define
parse-keyword-args
(fn
((raw-args :as list) (env :as dict))
(let
((kwargs (dict)) (children (list)) (i 0))
(reduce
(fn
(state arg)
(let
((idx (get state "i")) (skip (get state "skip")))
(if
skip
(assoc state "skip" false "i" (inc idx))
(if
(and
(= (type-of arg) "keyword")
(< (inc idx) (len raw-args)))
(do
(dict-set!
kwargs
(keyword-name arg)
(trampoline (eval-expr (nth raw-args (inc idx)) env)))
(assoc state "skip" true "i" (inc idx)))
(do
(append! children (trampoline (eval-expr arg env)))
(assoc state "i" (inc idx)))))))
(dict "i" 0 "skip" false)
raw-args)
(list kwargs children))))
(define
cond-scheme?
(fn
((clauses :as list))
(every?
(fn
(c)
(and
(= (type-of c) "list")
(or
(= (len c) 2)
(and
(= (len c) 3)
(= (type-of (nth c 1)) "symbol")
(= (symbol-name (nth c 1)) "=>")))))
clauses)))
(define
is-else-clause?
(fn
(test)
(or
(and (= (type-of test) "keyword") (= (keyword-name test) "else"))
(and
(= (type-of test) "symbol")
(or (= (symbol-name test) "else") (= (symbol-name test) ":else"))))))
(define
sf-named-let
(fn
((args :as list) (env :as dict))
(let
((loop-name (symbol-name (first args)))
(bindings (nth args 1))
(body (slice args 2))
(params (list))
(inits (list)))
(if
(and
(= (type-of (first bindings)) "list")
(= (len (first bindings)) 2))
(for-each
(fn
(binding)
(append!
params
(if
(= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding)))
(append! inits (nth binding 1)))
bindings)
(reduce
(fn
(acc pair-idx)
(do
(append!
params
(if
(= (type-of (nth bindings (* pair-idx 2))) "symbol")
(symbol-name (nth bindings (* pair-idx 2)))
(nth bindings (* pair-idx 2))))
(append! inits (nth bindings (inc (* pair-idx 2))))))
nil
(range 0 (/ (len bindings) 2))))
(let
((loop-body (if (= (len body) 1) (first body) (cons (make-symbol "begin") body)))
(loop-fn (make-lambda params loop-body env)))
(set-lambda-name! loop-fn loop-name)
(env-bind! (lambda-closure loop-fn) loop-name loop-fn)
(let
((init-vals (map (fn (e) (trampoline (eval-expr e env))) inits)))
(cek-call loop-fn init-vals))))))
(define
sf-lambda
(fn
((args :as list) (env :as dict))
(let
((params-expr (first args))
(body-exprs (rest args))
(body
(if
(= (len body-exprs) 1)
(first body-exprs)
(cons (make-symbol "begin") body-exprs)))
(param-names
(map
(fn
(p)
(cond
(= (type-of p) "symbol")
(symbol-name p)
(and
(= (type-of p) "list")
(= (len p) 3)
(= (type-of (nth p 1)) "keyword")
(= (keyword-name (nth p 1)) "as"))
(symbol-name (first p))
:else p))
params-expr)))
(make-lambda param-names body env))))
(define
sf-defcomp
(fn
((args :as list) (env :as dict))
(let
((name-sym (first args))
(params-raw (nth args 1))
(body (last args))
(comp-name (strip-prefix (symbol-name name-sym) "~"))
(parsed (parse-comp-params params-raw))
(params (first parsed))
(has-children (nth parsed 1))
(param-types (nth parsed 2))
(affinity (defcomp-kwarg args "affinity" "auto")))
(let
((comp (make-component comp-name params has-children body env affinity))
(effects (defcomp-kwarg args "effects" nil)))
(when
(and (not (nil? param-types)) (not (empty? (keys param-types))))
(component-set-param-types! comp param-types))
(when
(not (nil? effects))
(let
((effect-list (if (= (type-of effects) "list") (map (fn (e) (if (= (type-of e) "symbol") (symbol-name e) (str e))) effects) (list (str effects))))
(effect-anns
(if
(env-has? env "*effect-annotations*")
(env-get env "*effect-annotations*")
(dict))))
(dict-set! effect-anns (symbol-name name-sym) effect-list)
(env-bind! env "*effect-annotations*" effect-anns)))
(when
(env-has? env "*current-file*")
(component-set-file! comp (env-get env "*current-file*")))
(env-bind! env (symbol-name name-sym) comp)
comp))))
(define
defcomp-kwarg
(fn
((args :as list) (key :as string) default)
(let
((end (- (len args) 1)) (result default))
(for-each
(fn
(i)
(when
(and
(= (type-of (nth args i)) "keyword")
(= (keyword-name (nth args i)) key)
(< (+ i 1) end))
(let
((val (nth args (+ i 1))))
(set!
result
(if (= (type-of val) "keyword") (keyword-name val) val)))))
(range 2 end 1))
result)))
(define
parse-comp-params
(fn
((params-expr :as list))
(let
((params (list))
(param-types (dict))
(has-children false)
(in-key false))
(for-each
(fn
(p)
(if
(and
(= (type-of p) "list")
(= (len p) 3)
(= (type-of (first p)) "symbol")
(= (type-of (nth p 1)) "keyword")
(= (keyword-name (nth p 1)) "as"))
(let
((name (symbol-name (first p))) (ptype (nth p 2)))
(let
((type-val (if (= (type-of ptype) "symbol") (symbol-name ptype) ptype)))
(when
(not has-children)
(append! params name)
(dict-set! param-types name type-val))))
(when
(= (type-of p) "symbol")
(let
((name (symbol-name p)))
(cond
(= name "&key")
(set! in-key true)
(= name "&rest")
(set! has-children true)
(= name "&children")
(set! has-children true)
has-children
nil
in-key
(append! params name)
:else (append! params name))))))
params-expr)
(list params has-children param-types))))
(define
sf-defisland
(fn
((args :as list) (env :as dict))
(let
((name-sym (first args))
(params-raw (nth args 1))
(body-exprs (slice args 2))
(body
(if
(= (len body-exprs) 1)
(first body-exprs)
(cons (make-symbol "begin") body-exprs)))
(comp-name (strip-prefix (symbol-name name-sym) "~"))
(parsed (parse-comp-params params-raw))
(params (first parsed))
(has-children (nth parsed 1)))
(let
((island (make-island comp-name params has-children body env)))
(when
(env-has? env "*current-file*")
(component-set-file! island (env-get env "*current-file*")))
(env-bind! env (symbol-name name-sym) island)
island))))
(define
sf-defmacro
(fn
((args :as list) (env :as dict))
(let
((name-sym (first args))
(params-raw (nth args 1))
(body (nth args 2))
(parsed (parse-macro-params params-raw))
(params (first parsed))
(rest-param (nth parsed 1)))
(let
((mac (make-macro params rest-param body env (symbol-name name-sym))))
(env-bind! env (symbol-name name-sym) mac)
mac))))
(define
parse-macro-params
(fn
((params-expr :as list))
(let
((params (list)) (rest-param nil))
(reduce
(fn
(state p)
(if
(and (= (type-of p) "symbol") (= (symbol-name p) "&rest"))
(assoc state "in-rest" true)
(if
(get state "in-rest")
(do
(set!
rest-param
(if (= (type-of p) "symbol") (symbol-name p) p))
state)
(do
(append!
params
(if (= (type-of p) "symbol") (symbol-name p) p))
state))))
(dict "in-rest" false)
params-expr)
(list params rest-param))))
(define
qq-expand
(fn
(template (env :as dict))
(if
(not (= (type-of template) "list"))
template
(if
(empty? template)
(list)
(let
((head (first template)))
(if
(and
(= (type-of head) "symbol")
(= (symbol-name head) "unquote"))
(trampoline (eval-expr (nth template 1) env))
(reduce
(fn
(result item)
(if
(and
(= (type-of item) "list")
(= (len item) 2)
(= (type-of (first item)) "symbol")
(= (symbol-name (first item)) "splice-unquote"))
(let
((spliced (trampoline (eval-expr (nth item 1) env))))
(if
(= (type-of spliced) "list")
(concat result spliced)
(if
(nil? spliced)
result
(concat result (list spliced)))))
(concat result (list (qq-expand item env)))))
(list)
template)))))))
(define
sf-letrec
(fn
((args :as list) (env :as dict))
(let
((bindings (first args))
(body (rest args))
(local (env-extend env))
(names (list))
(val-exprs (list)))
(if
(and
(= (type-of (first bindings)) "list")
(= (len (first bindings)) 2))
(for-each
(fn
(binding)
(let
((vname (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (first binding))))
(append! names vname)
(append! val-exprs (nth binding 1))
(env-bind! local vname nil)))
bindings)
(reduce
(fn
(acc pair-idx)
(let
((vname (if (= (type-of (nth bindings (* pair-idx 2))) "symbol") (symbol-name (nth bindings (* pair-idx 2))) (nth bindings (* pair-idx 2))))
(val-expr (nth bindings (inc (* pair-idx 2)))))
(append! names vname)
(append! val-exprs val-expr)
(env-bind! local vname nil)))
nil
(range 0 (/ (len bindings) 2))))
(let
((values (map (fn (e) (trampoline (eval-expr e local))) val-exprs)))
(for-each
(fn (pair) (env-bind! local (first pair) (nth pair 1)))
(zip names values))
(for-each
(fn
(val)
(when
(lambda? val)
(for-each
(fn
(n)
(env-bind! (lambda-closure val) n (env-get local n)))
names)))
values))
(for-each
(fn (e) (trampoline (eval-expr e local)))
(slice body 0 (dec (len body))))
(make-thunk (last body) local))))
(define
step-sf-letrec
(fn
(args env kont)
(let
((thk (sf-letrec args env)))
(make-cek-state (thunk-expr thk) (thunk-env thk) kont))))
(define
sf-dynamic-wind
(fn
((args :as list) (env :as dict))
(let
((before (trampoline (eval-expr (first args) env)))
(body (trampoline (eval-expr (nth args 1) env)))
(after (trampoline (eval-expr (nth args 2) env))))
(dynamic-wind-call before body after env))))
(define
sf-scope
(fn
((args :as list) (env :as dict))
(let
((name (trampoline (eval-expr (first args) env)))
(rest (slice args 1))
(val nil)
(body-exprs nil))
(if
(and
(>= (len rest) 2)
(= (type-of (first rest)) "keyword")
(= (keyword-name (first rest)) "value"))
(do
(set! val (trampoline (eval-expr (nth rest 1) env)))
(set! body-exprs (slice rest 2)))
(set! body-exprs rest))
(scope-push! name val)
(let
((result nil))
(for-each
(fn (e) (set! result (trampoline (eval-expr e env))))
body-exprs)
(scope-pop! name)
result))))
(define
sf-provide
(fn
((args :as list) (env :as dict))
(let
((name (trampoline (eval-expr (first args) env)))
(val (trampoline (eval-expr (nth args 1) env)))
(body-exprs (slice args 2))
(result nil))
(scope-push! name val)
(for-each
(fn (e) (set! result (trampoline (eval-expr e env))))
body-exprs)
(scope-pop! name)
result)))
(define
expand-macro
(fn
((mac :as macro) (raw-args :as list) (env :as dict))
(let
((local (env-merge (macro-closure mac) env)))
(for-each
(fn
(pair)
(env-bind!
local
(first pair)
(if
(< (nth pair 1) (len raw-args))
(nth raw-args (nth pair 1))
nil)))
(map-indexed (fn (i p) (list p i)) (macro-params mac)))
(when
(macro-rest-param mac)
(env-bind!
local
(macro-rest-param mac)
(slice raw-args (len (macro-params mac)))))
(trampoline (eval-expr (macro-body mac) local)))))
(define
cek-run
(fn
(state)
(if (cek-terminal? state) (cek-value state) (cek-run (cek-step state)))))
(define
cek-step
(fn
(state)
(if
(= (cek-phase state) "eval")
(step-eval state)
(step-continue state))))
(define
step-eval
(fn
(state)
(let
((expr (cek-control state))
(env (cek-env state))
(kont (cek-kont state)))
(case
(type-of expr)
"number"
(make-cek-value expr env kont)
"string"
(make-cek-value expr env kont)
"boolean"
(make-cek-value expr env kont)
"nil"
(make-cek-value nil env kont)
"symbol"
(let
((name (symbol-name expr)))
(let
((val (cond (env-has? env name) (env-get env name) (primitive? name) (get-primitive name) (= name "true") true (= name "false") false (= name "nil") nil :else (error (str "Undefined symbol: " name)))))
(when
(and (nil? val) (starts-with? name "~"))
(debug-log "Component not found:" name))
(make-cek-value val env kont)))
"keyword"
(make-cek-value (keyword-name expr) env kont)
"dict"
(let
((ks (keys expr)))
(if
(empty? ks)
(make-cek-value (dict) env kont)
(let
((first-key (first ks)) (remaining-entries (list)))
(for-each
(fn (k) (append! remaining-entries (list k (get expr k))))
(rest ks))
(make-cek-state
(get expr first-key)
env
(kont-push
(make-dict-frame
remaining-entries
(list (list first-key))
env)
kont)))))
"list"
(if
(empty? expr)
(make-cek-value (list) env kont)
(step-eval-list expr env kont))
:else (make-cek-value expr env kont)))))
(define
step-sf-raise
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-raise-eval-frame env false) kont))))
(define
step-sf-guard
(fn
(args env kont)
(let
((var-clauses (first args))
(body (rest args))
(var (first var-clauses))
(clauses (rest var-clauses))
(sentinel (make-symbol "__guard-reraise__")))
(step-eval-list
(list
(quote let)
(list
(list
(quote __guard-result)
(cons
(quote call/cc)
(list
(cons
(quote fn)
(cons
(quote (__guard-k))
(list
(cons
(quote handler-bind)
(cons
(list
(list
(cons
(quote fn)
(cons (quote (_)) (quote (true))))
(cons
(quote fn)
(cons
(list var)
(list
(list
(quote __guard-k)
(cons
(quote cond)
(append
clauses
(list
(list
(quote else)
(list
(quote list)
(list
(quote quote)
sentinel)
var)))))))))))
(list
(list
(quote __guard-k)
(cons (quote begin) body))))))))))))
(list
(quote if)
(list
(quote and)
(list (quote list?) (quote __guard-result))
(list (quote =) (list (quote len) (quote __guard-result)) 2)
(list
(quote =)
(list (quote first) (quote __guard-result))
(list (quote quote) sentinel)))
(list
(quote raise)
(list (quote nth) (quote __guard-result) 1))
(quote __guard-result)))
env
kont))))
(define
step-eval-list
(fn
(expr env kont)
(let
((head (first expr)) (args (rest expr)))
(if
(not
(or
(= (type-of head) "symbol")
(= (type-of head) "lambda")
(= (type-of head) "list")))
(if
(empty? expr)
(make-cek-value (list) env kont)
(make-cek-state
(first expr)
env
(kont-push (make-map-frame nil (rest expr) (list) env) kont)))
(if
(= (type-of head) "symbol")
(let
((name (symbol-name head)))
(match
name
("if" (step-sf-if args env kont))
("when" (step-sf-when args env kont))
("cond" (step-sf-cond args env kont))
("case" (step-sf-case args env kont))
("and" (step-sf-and args env kont))
("or" (step-sf-or args env kont))
("let" (step-sf-let args env kont))
("let*" (step-sf-let args env kont))
("lambda" (step-sf-lambda args env kont))
("fn" (step-sf-lambda args env kont))
("define" (step-sf-define args env kont))
("defcomp" (make-cek-value (sf-defcomp args env) env kont))
("defisland" (make-cek-value (sf-defisland args env) env kont))
("defmacro" (make-cek-value (sf-defmacro args env) env kont))
("begin" (step-sf-begin args env kont))
("do"
(if
(and
(not (empty? args))
(list? (first args))
(not (empty? (first args)))
(list? (first (first args))))
(let
((bindings (first args))
(test-clause (nth args 1))
(body (rest (rest args)))
(vars (map (fn (b) (first b)) bindings))
(inits (map (fn (b) (nth b 1)) bindings))
(steps
(map
(fn (b) (if (> (len b) 2) (nth b 2) (first b)))
bindings))
(test (first test-clause))
(result (rest test-clause)))
(step-eval-list
(cons
(quote let)
(cons
(quote __do-loop)
(cons
(map
(fn (b) (list (first b) (nth b 1)))
bindings)
(list
(cons
(quote if)
(cons
test
(cons
(if
(empty? result)
nil
(cons (quote begin) result))
(list
(cons
(quote begin)
(append
body
(list
(cons (quote __do-loop) steps))))))))))))
env
kont))
(step-sf-begin args env kont)))
("guard" (step-sf-guard args env kont))
("quote"
(make-cek-value
(if (empty? args) nil (first args))
env
kont))
("quasiquote"
(make-cek-value (qq-expand (first args) env) env kont))
("->" (step-sf-thread-first args env kont))
("set!" (step-sf-set! args env kont))
("letrec" (step-sf-letrec args env kont))
("reset" (step-sf-reset args env kont))
("shift" (step-sf-shift args env kont))
("deref" (step-sf-deref args env kont))
("scope" (step-sf-scope args env kont))
("provide" (step-sf-provide args env kont))
("context" (step-sf-context args env kont))
("emit!" (step-sf-emit args env kont))
("emitted" (step-sf-emitted args env kont))
("handler-bind" (step-sf-handler-bind args env kont))
("restart-case" (step-sf-restart-case args env kont))
("signal-condition" (step-sf-signal args env kont))
("invoke-restart" (step-sf-invoke-restart args env kont))
("match" (step-sf-match args env kont))
("dynamic-wind"
(make-cek-value (sf-dynamic-wind args env) env kont))
("map" (step-ho-map args env kont))
("map-indexed" (step-ho-map-indexed args env kont))
("filter" (step-ho-filter args env kont))
("reduce" (step-ho-reduce args env kont))
("some" (step-ho-some args env kont))
("every?" (step-ho-every args env kont))
("for-each" (step-ho-for-each args env kont))
("raise" (step-sf-raise args env kont))
("raise-continuable"
(make-cek-state
(first args)
env
(kont-push (make-raise-eval-frame env true) kont)))
("call/cc" (step-sf-callcc args env kont))
("call-with-current-continuation"
(step-sf-callcc args env kont))
(_
(cond
(has-key? *custom-special-forms* name)
(make-cek-value
((get *custom-special-forms* name) args env)
env
kont)
(and (env-has? env name) (macro? (env-get env name)))
(let
((mac (env-get env name)))
(make-cek-state (expand-macro mac args env) env kont))
(and *render-check* (*render-check* expr env))
(make-cek-value (*render-fn* expr env) env kont)
:else (step-eval-call head args env kont)))))
(step-eval-call head args env kont))))))
(define
step-sf-callcc
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-callcc-frame env) kont))))
(define
match-find-clause
(fn
(val clauses env)
(if
(empty? clauses)
nil
(let
((clause (first clauses))
(pattern (first clause))
(body (nth clause 1))
(local (env-extend env)))
(if
(match-pattern pattern val local)
(list local body)
(match-find-clause val (rest clauses) env))))))
(define
match-pattern
(fn
(pattern value env)
(cond
(= pattern (quote _))
true
(and
(list? pattern)
(= (len pattern) 2)
(= (first pattern) (quote ?)))
(let
((pred (trampoline (eval-expr (nth pattern 1) env))))
(cek-call pred (list value)))
(and
(list? pattern)
(not (empty? pattern))
(= (first pattern) (quote quote)))
(= value (nth pattern 1))
(symbol? pattern)
(do (env-bind! env (symbol-name pattern) value) true)
(and (list? pattern) (list? value))
(if
(not (= (len pattern) (len value)))
false
(let
((pairs (zip pattern value)))
(every?
(fn (pair) (match-pattern (first pair) (nth pair 1) env))
pairs)))
:else (= pattern value))))
(define
step-sf-match
(fn
(args env kont)
(let
((val (trampoline (eval-expr (first args) env)))
(clauses (rest args)))
(let
((result (match-find-clause val clauses env)))
(if
(nil? result)
(error (str "match: no clause matched " (inspect val)))
(make-cek-state (nth result 1) (first result) kont))))))
(define
step-sf-handler-bind
(fn
(args env kont)
(let
((handler-specs (first args))
(body (rest args))
(handlers
(map
(fn
(spec)
(list
(trampoline (eval-expr (first spec) env))
(trampoline (eval-expr (nth spec 1) env))))
handler-specs)))
(if
(empty? body)
(make-cek-value nil env kont)
(make-cek-state
(first body)
env
(kont-push (make-handler-frame handlers (rest body) env) kont))))))
(define
step-sf-restart-case
(fn
(args env kont)
(let
((body (first args))
(restart-specs (rest args))
(restarts
(map
(fn
(spec)
(list
(if
(symbol? (first spec))
(symbol-name (first spec))
(first spec))
(nth spec 1)
(nth spec 2)))
restart-specs)))
(make-cek-state
body
env
(kont-push (make-restart-frame restarts (list) env) kont)))))
(define
step-sf-signal
(fn
(args env kont)
(let
((condition (trampoline (eval-expr (first args) env)))
(handler-fn (kont-find-handler kont condition)))
(if
(nil? handler-fn)
(error (str "Unhandled condition: " (inspect condition)))
(continue-with-call
handler-fn
(list condition)
env
(list condition)
(kont-push (make-signal-return-frame env kont) kont))))))
(define
step-sf-invoke-restart
(fn
(args env kont)
(let
((restart-name (let ((rn (if (symbol? (first args)) (symbol-name (first args)) (trampoline (eval-expr (first args) env))))) (if (symbol? rn) (symbol-name rn) rn)))
(restart-arg
(if
(>= (len args) 2)
(trampoline (eval-expr (nth args 1) env))
nil))
(found (kont-find-restart kont restart-name)))
(if
(nil? found)
(error (str "No restart named: " (inspect restart-name)))
(let
((entry (first found))
(restart-frame (nth found 1))
(rest-kont (nth found 2)))
(let
((params (nth entry 1))
(body (nth entry 2))
(restart-env (env-extend (get restart-frame "env"))))
(when
(not (empty? params))
(env-bind! restart-env (first params) restart-arg))
(make-cek-state body restart-env rest-kont)))))))
(define
step-sf-if
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push
(make-if-frame
(nth args 1)
(if (> (len args) 2) (nth args 2) nil)
env)
kont))))
(define
step-sf-when
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-when-frame (rest args) env) kont))))
(define
step-sf-begin
(fn
(args env kont)
(if
(empty? args)
(make-cek-value nil env kont)
(if
(= (len args) 1)
(make-cek-state (first args) env kont)
(make-cek-state
(first args)
env
(kont-push (make-begin-frame (rest args) env) kont))))))
(define
step-sf-let
(fn
(args env kont)
(if
(= (type-of (first args)) "symbol")
(make-cek-value (sf-named-let args env) env kont)
(let
((bindings (first args))
(body (rest args))
(local (env-extend env)))
(if
(empty? bindings)
(step-sf-begin body local kont)
(let
((first-binding (if (and (= (type-of (first bindings)) "list") (= (len (first bindings)) 2)) (first bindings) (list (first bindings) (nth bindings 1))))
(rest-bindings
(if
(and
(= (type-of (first bindings)) "list")
(= (len (first bindings)) 2))
(rest bindings)
(let
((pairs (list)))
(reduce
(fn
(acc i)
(append!
pairs
(list
(nth bindings (* i 2))
(nth bindings (inc (* i 2))))))
nil
(range 1 (/ (len bindings) 2)))
pairs))))
(let
((vname (if (= (type-of (first first-binding)) "symbol") (symbol-name (first first-binding)) (first first-binding))))
(make-cek-state
(nth first-binding 1)
local
(kont-push
(make-let-frame vname rest-bindings body local)
kont)))))))))
(define
step-sf-define
(fn
(args env kont)
(let
((name-sym (first args))
(has-effects
(and
(>= (len args) 4)
(= (type-of (nth args 1)) "keyword")
(= (keyword-name (nth args 1)) "effects")))
(val-idx
(if
(and
(>= (len args) 4)
(= (type-of (nth args 1)) "keyword")
(= (keyword-name (nth args 1)) "effects"))
3
1))
(effect-list
(if
(and
(>= (len args) 4)
(= (type-of (nth args 1)) "keyword")
(= (keyword-name (nth args 1)) "effects"))
(nth args 2)
nil)))
(make-cek-state
(nth args val-idx)
env
(kont-push
(make-define-frame
(symbol-name name-sym)
env
has-effects
effect-list)
kont)))))
(define
step-sf-set!
(fn
(args env kont)
(make-cek-state
(nth args 1)
env
(kont-push (make-set-frame (symbol-name (first args)) env) kont))))
(define
step-sf-and
(fn
(args env kont)
(if
(empty? args)
(make-cek-value true env kont)
(make-cek-state
(first args)
env
(kont-push (make-and-frame (rest args) env) kont)))))
(define
step-sf-or
(fn
(args env kont)
(if
(empty? args)
(make-cek-value false env kont)
(make-cek-state
(first args)
env
(kont-push (make-or-frame (rest args) env) kont)))))
(define
step-sf-cond
(fn
(args env kont)
(let
((scheme? (cond-scheme? args)))
(if
scheme?
(if
(empty? args)
(make-cek-value nil env kont)
(let
((clause (first args)) (test (first clause)))
(if
(is-else-clause? test)
(make-cek-state (nth clause 1) env kont)
(make-cek-state
test
env
(kont-push (make-cond-frame args env true) kont)))))
(if
(< (len args) 2)
(make-cek-value nil env kont)
(let
((test (first args)))
(if
(is-else-clause? test)
(make-cek-state (nth args 1) env kont)
(make-cek-state
test
env
(kont-push (make-cond-frame args env false) kont)))))))))
(define
step-sf-case
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-case-frame nil (rest args) env) kont))))
(define
step-sf-thread-first
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-thread-frame (rest args) env) kont))))
(define
step-sf-lambda
(fn (args env kont) (make-cek-value (sf-lambda args env) env kont)))
(define
step-sf-scope
(fn
(args env kont)
(let
((name (trampoline (eval-expr (first args) env)))
(rest-args (slice args 1))
(val nil)
(body nil))
(if
(and
(>= (len rest-args) 2)
(= (type-of (first rest-args)) "keyword")
(= (keyword-name (first rest-args)) "value"))
(do
(set! val (trampoline (eval-expr (nth rest-args 1) env)))
(set! body (slice rest-args 2)))
(set! body rest-args))
(if
(empty? body)
(make-cek-value nil env kont)
(make-cek-state
(first body)
env
(kont-push (make-scope-acc-frame name val (rest body) env) kont))))))
(define
step-sf-provide
(fn
(args env kont)
(let
((name (trampoline (eval-expr (first args) env)))
(val (trampoline (eval-expr (nth args 1) env)))
(body (slice args 2)))
(if
(empty? body)
(make-cek-value nil env kont)
(make-cek-state
(first body)
env
(kont-push (make-provide-frame name val (rest body) env) kont))))))
(define
step-sf-context
(fn
(args env kont)
(let
((name (trampoline (eval-expr (first args) env)))
(default-val
(if
(>= (len args) 2)
(trampoline (eval-expr (nth args 1) env))
nil))
(frame (kont-find-provide kont name)))
(make-cek-value
(if (nil? frame) default-val (get frame "value"))
env
kont))))
(define
step-sf-emit
(fn
(args env kont)
(let
((name (trampoline (eval-expr (first args) env)))
(val (trampoline (eval-expr (nth args 1) env)))
(frame (kont-find-scope-acc kont name)))
(when
frame
(dict-set!
frame
"emitted"
(append (get frame "emitted") (list val))))
(make-cek-value nil env kont))))
(define
step-sf-emitted
(fn
(args env kont)
(let
((name (trampoline (eval-expr (first args) env)))
(frame (kont-find-scope-acc kont name)))
(make-cek-value
(if (nil? frame) (list) (get frame "emitted"))
env
kont))))
(define
step-sf-reset
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-reset-frame env) kont))))
(define
step-sf-shift
(fn
(args env kont)
(let
((k-name (symbol-name (first args)))
(body (nth args 1))
(captured-result (kont-capture-to-reset kont))
(captured (first captured-result))
(rest-kont (nth captured-result 1)))
(let
((k (make-cek-continuation captured rest-kont)))
(let
((shift-env (env-extend env)))
(env-bind! shift-env k-name k)
(make-cek-state body shift-env rest-kont))))))
(define
step-sf-deref
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-deref-frame env) kont))))
(define
cek-call
(fn
(f args)
(let
((a (if (nil? args) (list) args)))
(cond
(nil? f)
nil
(or (lambda? f) (callable? f))
(cek-run (continue-with-call f a (make-env) a (list)))
:else nil))))
(define
reactive-shift-deref
(fn
(sig env kont)
(let
((scan-result (kont-capture-to-reactive-reset kont))
(captured-frames (first scan-result))
(reset-frame (nth scan-result 1))
(remaining-kont (nth scan-result 2))
(update-fn (get reset-frame "update-fn")))
(let
((sub-disposers (list)))
(let
((subscriber (fn () (for-each (fn (d) (cek-call d nil)) sub-disposers) (set! sub-disposers (list)) (let ((new-reset (make-reactive-reset-frame env update-fn false)) (new-kont (concat captured-frames (list new-reset) remaining-kont))) (with-island-scope (fn (d) (append! sub-disposers d)) (fn () (cek-run (make-cek-value (signal-value sig) env new-kont))))))))
(signal-add-sub! sig subscriber)
(register-in-scope
(fn
()
(signal-remove-sub! sig subscriber)
(for-each (fn (d) (cek-call d nil)) sub-disposers)))
(let
((initial-kont (concat captured-frames (list reset-frame) remaining-kont)))
(make-cek-value (signal-value sig) env initial-kont)))))))
(define
step-eval-call
(fn
(head args env kont)
(let
((hname (if (= (type-of head) "symbol") (symbol-name head) nil)))
(make-cek-state
head
env
(kont-push (make-arg-frame nil (list) args env args hname) kont)))))
(define
ho-form-name?
(fn
(name)
(or
(= name "map")
(= name "map-indexed")
(= name "filter")
(= name "reduce")
(= name "some")
(= name "every?")
(= name "for-each"))))
(define ho-fn? (fn (v) (or (callable? v) (lambda? v))))
(define
ho-swap-args
(fn
(ho-type evaled)
(if
(= ho-type "reduce")
(let
((a (first evaled)) (b (nth evaled 1)))
(if
(and (not (ho-fn? a)) (ho-fn? b))
(list b (nth evaled 2) a)
evaled))
(let
((a (first evaled)) (b (nth evaled 1)))
(if (and (not (ho-fn? a)) (ho-fn? b)) (list b a) evaled)))))
(define
ho-setup-dispatch
(fn
(ho-type evaled env kont)
(let
((ordered (ho-swap-args ho-type evaled)))
(let
((f (first ordered)))
(match
ho-type
("map"
(if
(> (len ordered) 2)
(let
((colls (rest ordered)))
(if
(some (fn (c) (empty? c)) colls)
(make-cek-value (list) env kont)
(let
((heads (map (fn (c) (first c)) colls))
(tails (map (fn (c) (rest c)) colls)))
(continue-with-call
f
heads
env
(list)
(kont-push
(make-multi-map-frame f tails (list) env)
kont)))))
(let
((coll (nth ordered 1)))
(if
(empty? coll)
(make-cek-value (list) env kont)
(continue-with-call
f
(list (first coll))
env
(list)
(kont-push
(make-map-frame f (rest coll) (list) env)
kont))))))
("map-indexed"
(let
((coll (nth ordered 1)))
(if
(empty? coll)
(make-cek-value (list) env kont)
(continue-with-call
f
(list 0 (first coll))
env
(list)
(kont-push
(make-map-indexed-frame f (rest coll) (list) env)
kont)))))
("filter"
(let
((coll (nth ordered 1)))
(if
(empty? coll)
(make-cek-value (list) env kont)
(continue-with-call
f
(list (first coll))
env
(list)
(kont-push
(make-filter-frame
f
(rest coll)
(list)
(first coll)
env)
kont)))))
("reduce"
(let
((init (nth ordered 1)) (coll (nth ordered 2)))
(if
(empty? coll)
(make-cek-value init env kont)
(continue-with-call
f
(list init (first coll))
env
(list)
(kont-push (make-reduce-frame f (rest coll) env) kont)))))
("some"
(let
((coll (nth ordered 1)))
(if
(empty? coll)
(make-cek-value false env kont)
(continue-with-call
f
(list (first coll))
env
(list)
(kont-push (make-some-frame f (rest coll) env) kont)))))
("every"
(let
((coll (nth ordered 1)))
(if
(empty? coll)
(make-cek-value true env kont)
(continue-with-call
f
(list (first coll))
env
(list)
(kont-push (make-every-frame f (rest coll) env) kont)))))
("for-each"
(let
((coll (nth ordered 1)))
(if
(empty? coll)
(make-cek-value nil env kont)
(continue-with-call
f
(list (first coll))
env
(list)
(kont-push (make-for-each-frame f (rest coll) env) kont)))))
(_ (error (str "Unknown HO type: " ho-type))))))))
(define
step-ho-map
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-ho-setup-frame "map" (rest args) (list) env) kont))))
(define
step-ho-map-indexed
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push
(make-ho-setup-frame "map-indexed" (rest args) (list) env)
kont))))
(define
step-ho-filter
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-ho-setup-frame "filter" (rest args) (list) env) kont))))
(define
step-ho-reduce
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-ho-setup-frame "reduce" (rest args) (list) env) kont))))
(define
step-ho-some
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-ho-setup-frame "some" (rest args) (list) env) kont))))
(define
step-ho-every
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push (make-ho-setup-frame "every" (rest args) (list) env) kont))))
(define
step-ho-for-each
(fn
(args env kont)
(make-cek-state
(first args)
env
(kont-push
(make-ho-setup-frame "for-each" (rest args) (list) env)
kont))))
(define
step-continue
(fn
(state)
(let
((value (cek-value state))
(env (cek-env state))
(kont (cek-kont state)))
(if
(kont-empty? kont)
state
(let
((frame (kont-top kont))
(rest-k (kont-pop kont))
(ft (frame-type frame)))
(match
ft
("if"
(if
(and value (not (nil? value)))
(make-cek-state (get frame "then") (get frame "env") rest-k)
(if
(nil? (get frame "else"))
(make-cek-value nil env rest-k)
(make-cek-state
(get frame "else")
(get frame "env")
rest-k))))
("when"
(if
(and value (not (nil? value)))
(let
((body (get frame "body")) (fenv (get frame "env")))
(if
(empty? body)
(make-cek-value nil fenv rest-k)
(if
(= (len body) 1)
(make-cek-state (first body) fenv rest-k)
(make-cek-state
(first body)
fenv
(kont-push
(make-begin-frame (rest body) fenv)
rest-k)))))
(make-cek-value nil env rest-k)))
("begin"
(let
((remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
(empty? remaining)
(make-cek-value value fenv rest-k)
(if
(= (len remaining) 1)
(make-cek-state (first remaining) fenv rest-k)
(make-cek-state
(first remaining)
fenv
(kont-push
(make-begin-frame (rest remaining) fenv)
rest-k))))))
("let"
(let
((name (get frame "name"))
(remaining (get frame "remaining"))
(body (get frame "body"))
(local (get frame "env")))
(env-bind! local name value)
(if
(empty? remaining)
(step-sf-begin body local rest-k)
(let
((next-binding (first remaining))
(vname
(if
(= (type-of (first next-binding)) "symbol")
(symbol-name (first next-binding))
(first next-binding))))
(make-cek-state
(nth next-binding 1)
local
(kont-push
(make-let-frame vname (rest remaining) body local)
rest-k))))))
("define"
(let
((name (get frame "name"))
(fenv (get frame "env"))
(has-effects (get frame "has-effects"))
(effect-list (get frame "effect-list")))
(when
(and (lambda? value) (nil? (lambda-name value)))
(set-lambda-name! value name))
(env-bind! fenv name value)
(when
has-effects
(let
((effect-names (map (fn (e) (if (= (type-of e) "symbol") (symbol-name e) e)) effect-list))
(effect-anns
(if
(env-has? fenv "*effect-annotations*")
(env-get fenv "*effect-annotations*")
(dict))))
(dict-set! effect-anns name effect-names)
(env-bind! fenv "*effect-annotations*" effect-anns)))
(make-cek-value value fenv rest-k)))
("set"
(let
((name (get frame "name")) (fenv (get frame "env")))
(env-set! fenv name value)
(make-cek-value value env rest-k)))
("and"
(if
(not value)
(make-cek-value value env rest-k)
(let
((remaining (get frame "remaining")))
(if
(empty? remaining)
(make-cek-value value env rest-k)
(make-cek-state
(first remaining)
(get frame "env")
(if
(= (len remaining) 1)
rest-k
(kont-push
(make-and-frame (rest remaining) (get frame "env"))
rest-k)))))))
("or"
(if
value
(make-cek-value value env rest-k)
(let
((remaining (get frame "remaining")))
(if
(empty? remaining)
(make-cek-value false env rest-k)
(make-cek-state
(first remaining)
(get frame "env")
(if
(= (len remaining) 1)
rest-k
(kont-push
(make-or-frame (rest remaining) (get frame "env"))
rest-k)))))))
("cond"
(let
((remaining (get frame "remaining"))
(fenv (get frame "env"))
(scheme? (get frame "scheme")))
(if
scheme?
(if
value
(let
((clause (first remaining)))
(if
(and
(> (len clause) 2)
(= (type-of (nth clause 1)) "symbol")
(= (symbol-name (nth clause 1)) "=>"))
(make-cek-state
(nth clause 2)
fenv
(kont-push
(make-cond-arrow-frame value fenv)
rest-k))
(make-cek-state (nth clause 1) fenv rest-k)))
(let
((next-clauses (rest remaining)))
(if
(empty? next-clauses)
(make-cek-value nil fenv rest-k)
(let
((next-clause (first next-clauses))
(next-test (first next-clause)))
(if
(is-else-clause? next-test)
(make-cek-state (nth next-clause 1) fenv rest-k)
(make-cek-state
next-test
fenv
(kont-push
(make-cond-frame next-clauses fenv true)
rest-k)))))))
(if
value
(make-cek-state (nth remaining 1) fenv rest-k)
(let
((next (slice remaining 2 (len remaining))))
(if
(< (len next) 2)
(make-cek-value nil fenv rest-k)
(let
((next-test (first next)))
(if
(is-else-clause? next-test)
(make-cek-state (nth next 1) fenv rest-k)
(make-cek-state
next-test
fenv
(kont-push
(make-cond-frame next fenv false)
rest-k))))))))))
("case"
(let
((match-val (get frame "match-val"))
(remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
(nil? match-val)
(sf-case-step-loop value remaining fenv rest-k)
(sf-case-step-loop match-val remaining fenv rest-k))))
("thread"
(let
((remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
(empty? remaining)
(make-cek-value value fenv rest-k)
(let
((form (first remaining))
(rest-forms (rest remaining))
(new-kont
(if
(empty? (rest remaining))
rest-k
(kont-push
(make-thread-frame (rest remaining) fenv)
rest-k))))
(if
(and
(= (type-of form) "list")
(not (empty? form))
(= (type-of (first form)) "symbol")
(ho-form-name? (symbol-name (first form))))
(make-cek-state
(cons
(first form)
(cons (list (quote quote) value) (rest form)))
fenv
new-kont)
(let
((result (thread-insert-arg form value fenv)))
(if
(empty? rest-forms)
(make-cek-value result fenv rest-k)
(make-cek-value
result
fenv
(kont-push
(make-thread-frame rest-forms fenv)
rest-k)))))))))
("arg"
(let
((f (get frame "f"))
(evaled (get frame "evaled"))
(remaining (get frame "remaining"))
(fenv (get frame "env"))
(raw-args (get frame "raw-args"))
(hname (get frame "head-name")))
(if
(nil? f)
(do
(when
(and *strict* hname)
(strict-check-args hname (list)))
(if
(empty? remaining)
(continue-with-call value (list) fenv raw-args rest-k)
(make-cek-state
(first remaining)
fenv
(kont-push
(make-arg-frame
value
(list)
(rest remaining)
fenv
raw-args
hname)
rest-k))))
(let
((new-evaled (append evaled (list value))))
(if
(empty? remaining)
(do
(when
(and *strict* hname)
(strict-check-args hname new-evaled))
(continue-with-call f new-evaled fenv raw-args rest-k))
(make-cek-state
(first remaining)
fenv
(kont-push
(make-arg-frame
f
new-evaled
(rest remaining)
fenv
raw-args
hname)
rest-k)))))))
("dict"
(let
((remaining (get frame "remaining"))
(results (get frame "results"))
(fenv (get frame "env")))
(let
((last-result (last results))
(completed
(append
(slice results 0 (dec (len results)))
(list (list (first last-result) value)))))
(if
(empty? remaining)
(let
((d (dict)))
(for-each
(fn (pair) (dict-set! d (first pair) (nth pair 1)))
completed)
(make-cek-value d fenv rest-k))
(let
((next-entry (first remaining)))
(make-cek-state
(nth next-entry 1)
fenv
(kont-push
(make-dict-frame
(rest remaining)
(append
completed
(list (list (first next-entry))))
fenv)
rest-k)))))))
("ho-setup"
(let
((ho-type (get frame "ho-type"))
(remaining (get frame "remaining"))
(evaled (append (get frame "evaled") (list value)))
(fenv (get frame "env")))
(if
(empty? remaining)
(ho-setup-dispatch ho-type evaled fenv rest-k)
(make-cek-state
(first remaining)
fenv
(kont-push
(make-ho-setup-frame
ho-type
(rest remaining)
evaled
fenv)
rest-k)))))
("reset" (make-cek-value value env rest-k))
("deref"
(let
((val value) (fenv (get frame "env")))
(if
(not (signal? val))
(make-cek-value val fenv rest-k)
(if
(has-reactive-reset-frame? rest-k)
(reactive-shift-deref val fenv rest-k)
(do
(let
((ctx (context "sx-reactive" nil)))
(when
ctx
(let
((dep-list (get ctx "deps"))
(notify-fn (get ctx "notify")))
(when
(not (contains? dep-list val))
(append! dep-list val)
(signal-add-sub! val notify-fn)))))
(make-cek-value (signal-value val) fenv rest-k))))))
("reactive-reset"
(let
((update-fn (get frame "update-fn"))
(first? (get frame "first-render")))
(when
(and update-fn (not first?))
(cek-call update-fn (list value)))
(make-cek-value value env rest-k)))
("scope"
(let
((name (get frame "name"))
(remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
(empty? remaining)
(do (scope-pop! name) (make-cek-value value fenv rest-k))
(make-cek-state
(first remaining)
fenv
(kont-push
(make-scope-frame name (rest remaining) fenv)
rest-k)))))
("provide"
(let
((remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
(empty? remaining)
(make-cek-value value fenv rest-k)
(make-cek-state
(first remaining)
fenv
(kont-push
(make-provide-frame
(get frame "name")
(get frame "value")
(rest remaining)
fenv)
rest-k)))))
("scope-acc"
(let
((remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
(empty? remaining)
(make-cek-value value fenv rest-k)
(make-cek-state
(first remaining)
fenv
(kont-push
(let
((new-frame (make-scope-acc-frame (get frame "name") (get frame "value") (rest remaining) fenv)))
(dict-set! new-frame "emitted" (get frame "emitted"))
new-frame)
rest-k)))))
("map"
(let
((f (get frame "f"))
(remaining (get frame "remaining"))
(results (get frame "results"))
(indexed (get frame "indexed"))
(fenv (get frame "env")))
(let
((new-results (append results (list value))))
(if
(empty? remaining)
(make-cek-value new-results fenv rest-k)
(let
((call-args (if indexed (list (len new-results) (first remaining)) (list (first remaining))))
(next-frame
(if
indexed
(make-map-indexed-frame
f
(rest remaining)
new-results
fenv)
(make-map-frame
f
(rest remaining)
new-results
fenv))))
(continue-with-call
f
call-args
fenv
(list)
(kont-push next-frame rest-k)))))))
("filter"
(let
((f (get frame "f"))
(remaining (get frame "remaining"))
(results (get frame "results"))
(current-item (get frame "current-item"))
(fenv (get frame "env")))
(let
((new-results (if value (append results (list current-item)) results)))
(if
(empty? remaining)
(make-cek-value new-results fenv rest-k)
(continue-with-call
f
(list (first remaining))
fenv
(list)
(kont-push
(make-filter-frame
f
(rest remaining)
new-results
(first remaining)
fenv)
rest-k))))))
("reduce"
(let
((f (get frame "f"))
(remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
(empty? remaining)
(make-cek-value value fenv rest-k)
(continue-with-call
f
(list value (first remaining))
fenv
(list)
(kont-push
(make-reduce-frame f (rest remaining) fenv)
rest-k)))))
("for-each"
(let
((f (get frame "f"))
(remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
(empty? remaining)
(make-cek-value nil fenv rest-k)
(continue-with-call
f
(list (first remaining))
fenv
(list)
(kont-push
(make-for-each-frame f (rest remaining) fenv)
rest-k)))))
("some"
(let
((f (get frame "f"))
(remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
value
(make-cek-value value fenv rest-k)
(if
(empty? remaining)
(make-cek-value false fenv rest-k)
(continue-with-call
f
(list (first remaining))
fenv
(list)
(kont-push
(make-some-frame f (rest remaining) fenv)
rest-k))))))
("every"
(let
((f (get frame "f"))
(remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
(not value)
(make-cek-value false fenv rest-k)
(if
(empty? remaining)
(make-cek-value true fenv rest-k)
(continue-with-call
f
(list (first remaining))
fenv
(list)
(kont-push
(make-every-frame f (rest remaining) fenv)
rest-k))))))
("handler"
(let
((remaining (get frame "remaining"))
(fenv (get frame "env")))
(if
(empty? remaining)
(make-cek-value value fenv rest-k)
(make-cek-state
(first remaining)
fenv
(kont-push
(make-handler-frame
(get frame "f")
(rest remaining)
fenv)
rest-k)))))
("restart" (make-cek-value value env rest-k))
("signal-return"
(let
((saved-kont (get frame "saved-kont")))
(make-cek-value value (get frame "env") saved-kont)))
("comp-trace" (make-cek-value value env rest-k))
("cond-arrow"
(let
((test-value (get frame "match-val"))
(fenv (get frame "env")))
(continue-with-call
value
(list test-value)
fenv
(list test-value)
rest-k)))
("raise-eval"
(let
((condition value)
(fenv (get frame "env"))
(continuable? (get frame "scheme"))
(handler-fn (kont-find-handler rest-k condition)))
(if
(nil? handler-fn)
(host-error
(str "Unhandled exception: " (inspect condition)))
(continue-with-call
handler-fn
(list condition)
fenv
(list condition)
(if
continuable?
(kont-push
(make-signal-return-frame fenv rest-k)
rest-k)
(kont-push (make-raise-guard-frame fenv rest-k) rest-k))))))
("raise-guard"
(host-error
"exception handler returned from non-continuable raise"))
("multi-map"
(let
((f (get frame "f"))
(remaining (get frame "remaining"))
(new-results (append (get frame "results") (list value)))
(fenv (get frame "env")))
(if
(some (fn (c) (empty? c)) remaining)
(make-cek-value new-results fenv rest-k)
(let
((heads (map (fn (c) (first c)) remaining))
(tails (map (fn (c) (rest c)) remaining)))
(continue-with-call
f
heads
fenv
(list)
(kont-push
(make-multi-map-frame f tails new-results fenv)
rest-k))))))
("callcc"
(let
((k (make-callcc-continuation rest-k)))
(continue-with-call
value
(list k)
(get frame "env")
(list k)
rest-k)))
(_ (error (str "Unknown frame type: " ft)))))))))
(define
continue-with-call
(fn
(f args env raw-args kont)
(cond
(callcc-continuation? f)
(let
((arg (if (empty? args) nil (first args)))
(captured (callcc-continuation-data f)))
(make-cek-value arg env captured))
(continuation? f)
(let
((arg (if (empty? args) nil (first args)))
(cont-data (continuation-data f)))
(let
((captured (get cont-data "captured")))
(let
((result (cek-run (make-cek-value arg env captured))))
(make-cek-value result env kont))))
(and
(callable? f)
(not (lambda? f))
(not (component? f))
(not (island? f)))
(make-cek-value (apply f args) env kont)
(lambda? f)
(let
((params (lambda-params f))
(local (env-merge (lambda-closure f) env)))
(when
(not (bind-lambda-params params args local))
(when
(> (len args) (len params))
(error
(str
(or (lambda-name f) "lambda")
" expects "
(len params)
" args, got "
(len args))))
(for-each
(fn (pair) (env-bind! local (first pair) (nth pair 1)))
(zip params args))
(for-each
(fn (p) (env-bind! local p nil))
(slice params (len args))))
(make-cek-state (lambda-body f) local kont))
(or (component? f) (island? f))
(let
((parsed (parse-keyword-args raw-args env))
(kwargs (first parsed))
(children (nth parsed 1))
(local (env-merge (component-closure f) env)))
(for-each
(fn (p) (env-bind! local p (or (dict-get kwargs p) nil)))
(component-params f))
(when
(component-has-children? f)
(env-bind! local "children" children))
(make-cek-state
(component-body f)
local
(kont-push
(make-comp-trace-frame (component-name f) (component-file f))
kont)))
:else (error (str "Not callable: " (inspect f))))))
(define
sf-case-step-loop
(fn
(match-val clauses env kont)
(if
(< (len clauses) 2)
(make-cek-value nil env kont)
(let
((test (first clauses)) (body (nth clauses 1)))
(if
(is-else-clause? test)
(make-cek-state body env kont)
(let
((test-val (trampoline (eval-expr test env))))
(if
(= match-val test-val)
(make-cek-state body env kont)
(sf-case-step-loop match-val (slice clauses 2) env kont))))))))
(define
eval-expr-cek
(fn (expr env) (cek-run (make-cek-state expr env (list)))))
(define
trampoline-cek
(fn
(val)
(if (thunk? val) (eval-expr-cek (thunk-expr val) (thunk-env val)) val)))
(define
eval-expr
(fn (expr (env :as dict)) (cek-run (make-cek-state expr env (list)))))
(define
trampoline
(fn
(val)
(if (thunk? val) (eval-expr (thunk-expr val) (thunk-env val)) val)))
Reference in New Issue View Git Blame Copy Permalink