spec: sequence protocol Spec step — seq-to-list + ho polymorphic dispatch
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 15s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 15s
- seq-to-list: coerce list/vector/string/nil to list - ho-setup-dispatch: apply seq-to-list to all collection args so map/filter/ reduce/for-each/some/every? work over vectors and strings natively - sequence->list, sequence->vector, sequence-length, sequence-ref, sequence-append: full polymorphic sequence helpers - in-range: list-returning range generator (eager, works with all HO forms) - Restore 3 accidentally-deleted make-cek-state/make-cek-value/make-cek-suspended - Fix 8 shorthand define forms (transpiler requires long form) - Add vector->list/list->vector to transpiler js-renames + platform aliases - JS: 2137 passing (+28 vs HEAD baseline) Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
@@ -25,6 +25,10 @@
|
||||
|
||||
(define cek-kont (fn (s) (get s "kont")))
|
||||
|
||||
(define cek-phase (fn (s) (get s "phase")))
|
||||
|
||||
(define cek-io-request (fn (s) (get s "request")))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 2: Continuation Frames
|
||||
;;
|
||||
@@ -32,10 +36,6 @@
|
||||
;; when the current sub-expression finishes evaluating. The kont
|
||||
;; (continuation) is a list of frames, forming a reified call stack.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define cek-phase (fn (s) (get s "phase")))
|
||||
|
||||
(define cek-io-request (fn (s) (get s "request")))
|
||||
|
||||
(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}))
|
||||
@@ -44,11 +44,11 @@
|
||||
|
||||
(define make-begin-frame (fn (remaining env) {:env env :type "begin" :remaining remaining}))
|
||||
|
||||
;; Function call frames: accumulate evaluated args, then dispatch
|
||||
(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}))
|
||||
|
||||
;; Function call frames: accumulate evaluated args, then dispatch
|
||||
(define make-define-foreign-frame (fn (name spec env) {:spec spec :env env :type "define-foreign" :name name}))
|
||||
|
||||
(define make-set-frame (fn (name env) {:env env :type "set" :name name}))
|
||||
@@ -61,11 +61,11 @@
|
||||
|
||||
(define make-cond-frame (fn (remaining env scheme?) {:scheme scheme? :env env :type "cond" :remaining remaining}))
|
||||
|
||||
;; Higher-order iteration frames
|
||||
(define make-cond-arrow-frame (fn (test-value env) {:env env :match-val test-value :type "cond-arrow"}))
|
||||
|
||||
(define make-case-frame (fn (match-val remaining env) {:match-val match-val :env env :type "case" :remaining remaining}))
|
||||
|
||||
;; Higher-order iteration frames
|
||||
(define make-thread-frame (fn (remaining env mode name) {:env env :type "thread" :extra mode :remaining remaining :name name}))
|
||||
|
||||
(define
|
||||
@@ -94,44 +94,43 @@
|
||||
|
||||
(define make-multi-map-frame (fn (f remaining-lists results env) {:env env :results results :type "multi-map" :f f :remaining remaining-lists}))
|
||||
|
||||
;; Scope/provide/context — downward data passing without env threading
|
||||
(define
|
||||
make-filter-frame
|
||||
(fn (f remaining results current-item env) {:current-item current-item :env env :results results :type "filter" :f f :remaining remaining}))
|
||||
|
||||
(define make-reduce-frame (fn (f remaining env) {:env env :type "reduce" :f f :remaining remaining}))
|
||||
|
||||
;; Scope/provide/context — downward data passing without env threading
|
||||
(define make-for-each-frame (fn (f remaining env) {:env env :type "for-each" :f f :remaining remaining}))
|
||||
|
||||
;; Delimited continuations (shift/reset)
|
||||
(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}))
|
||||
|
||||
;; Delimited continuations (shift/reset)
|
||||
(define make-scope-frame (fn (name remaining env) {:env env :type "scope" :remaining remaining :name name}))
|
||||
|
||||
(define make-provide-frame (fn (name value remaining env) {:subscribers (list) :env env :value value :type "provide" :remaining remaining :name name}))
|
||||
|
||||
;; Dynamic wind + reactive signals
|
||||
(define make-bind-frame (fn (body env prev-tracking) {:body body :env env :type "bind" :prev-tracking prev-tracking}))
|
||||
|
||||
(define make-provide-set-frame (fn (name env) {:env env :type "provide-set" :name name}))
|
||||
|
||||
;; Undelimited continuations (call/cc)
|
||||
;; Dynamic wind + reactive signals
|
||||
(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"}))
|
||||
|
||||
;; HO setup: staged argument evaluation for map/filter/etc.
|
||||
;; Evaluates args one at a time, then dispatches to the correct
|
||||
;; HO frame (map, filter, reduce) once all args are ready.
|
||||
;; Undelimited continuations (call/cc)
|
||||
(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}))
|
||||
|
||||
;; HO setup: staged argument evaluation for map/filter/etc.
|
||||
;; Evaluates args one at a time, then dispatches to the correct
|
||||
;; HO frame (map, filter, reduce) once all args are ready.
|
||||
(define make-or-frame (fn (remaining env) {:env env :type "or" :remaining remaining}))
|
||||
|
||||
;; Condition system frames (handler-bind, restart-case, signal)
|
||||
(define
|
||||
make-dynamic-wind-frame
|
||||
(fn (phase body-thunk after-thunk env) {:env env :phase phase :after-thunk after-thunk :type "dynamic-wind" :body-thunk body-thunk}))
|
||||
@@ -140,31 +139,20 @@
|
||||
make-reactive-reset-frame
|
||||
(fn (env update-fn first-render?) {:first-render first-render? :update-fn update-fn :env env :type "reactive-reset"}))
|
||||
|
||||
;; Condition system frames (handler-bind, restart-case, signal)
|
||||
(define make-callcc-frame (fn (env) {:env env :type "callcc"}))
|
||||
|
||||
(define
|
||||
make-wind-after-frame
|
||||
(fn (after-thunk winders-len env)
|
||||
{:type "wind-after" :after-thunk after-thunk :winders-len winders-len :env env}))
|
||||
(define make-wind-after-frame (fn (after-thunk winders-len env) {:winders-len winders-len :env env :after-thunk after-thunk :type "wind-after"}))
|
||||
|
||||
(define
|
||||
make-wind-return-frame
|
||||
(fn (body-result env)
|
||||
{:type "wind-return" :body-result body-result :env env}))
|
||||
(define make-wind-return-frame (fn (body-result env) {:body-result body-result :env env :type "wind-return"}))
|
||||
|
||||
;; R7RS exception frames (raise, guard)
|
||||
(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}))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 3: Continuation Stack Operations
|
||||
;;
|
||||
;; Searching and manipulating the kont list — finding handlers,
|
||||
;; restarts, scope accumulators, and capturing delimited slices.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; R7RS exception frames (raise, guard)
|
||||
(define make-comp-trace-frame (fn (name file) {:env file :type "comp-trace" :name name}))
|
||||
|
||||
(define
|
||||
@@ -181,28 +169,34 @@
|
||||
(cons {:file (get frame "file") :name (get frame "name")} (kont-collect-comp-trace (rest kont)))
|
||||
(kont-collect-comp-trace (rest kont)))))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 3: Continuation Stack Operations
|
||||
;;
|
||||
;; Searching and manipulating the kont list — finding handlers,
|
||||
;; restarts, scope accumulators, and capturing delimited slices.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(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}))
|
||||
|
||||
;; Basic kont operations
|
||||
(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"}))
|
||||
|
||||
;; Basic kont operations
|
||||
(define make-raise-guard-frame (fn (env saved-kont) {:env env :type "raise-guard" :remaining saved-kont}))
|
||||
|
||||
(define make-perform-frame (fn (env) {:env env :type "perform"}))
|
||||
|
||||
(define make-vm-resume-frame (fn (resume-fn env) {:env env :type "vm-resume" :f resume-fn}))
|
||||
|
||||
;; Capture frames up to a reset boundary — used by shift
|
||||
(define make-import-frame (fn (import-set remaining-sets env) {:args import-set :env env :type "import" :remaining remaining-sets}))
|
||||
|
||||
(define
|
||||
make-parameterize-frame
|
||||
(fn (remaining current-param results body env) {:env env :body body :results results :type "parameterize" :f current-param :remaining remaining}))
|
||||
|
||||
;; Capture frames up to a reset boundary — used by shift
|
||||
(define
|
||||
find-matching-handler
|
||||
(fn
|
||||
@@ -240,7 +234,8 @@
|
||||
|
||||
(define
|
||||
kont-unwind-to-handler
|
||||
(fn (kont condition)
|
||||
(fn
|
||||
(kont condition)
|
||||
(if
|
||||
(empty? kont)
|
||||
{:handler nil :kont kont}
|
||||
@@ -261,8 +256,7 @@
|
||||
(set! *winders* (rest *winders*)))
|
||||
(cek-call (get frame "after-thunk") (list))
|
||||
(kont-unwind-to-handler rest-k condition))
|
||||
:else
|
||||
(kont-unwind-to-handler rest-k condition))))))
|
||||
:else (kont-unwind-to-handler rest-k condition))))))
|
||||
|
||||
(define
|
||||
wind-escape-to
|
||||
@@ -290,12 +284,6 @@
|
||||
entry
|
||||
(find-named-restart (rest restarts) name))))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 4: Extension Points & Mutable State
|
||||
;;
|
||||
;; Custom special forms registry, render hooks, strict mode.
|
||||
;; Mutable globals use set! — the transpiler emits OCaml refs.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define
|
||||
kont-find-restart
|
||||
(fn
|
||||
@@ -317,6 +305,12 @@
|
||||
|
||||
(define frame-type (fn (f) (get f "type")))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 4: Extension Points & Mutable State
|
||||
;;
|
||||
;; Custom special forms registry, render hooks, strict mode.
|
||||
;; Mutable globals use set! — the transpiler emits OCaml refs.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define kont-push (fn (frame kont) (cons frame kont)))
|
||||
|
||||
(define kont-top (fn (kont) (first kont)))
|
||||
@@ -359,7 +353,11 @@
|
||||
(rest pairs)
|
||||
env
|
||||
(cons
|
||||
(make-provide-frame (first pair) (nth pair 1) (list) env)
|
||||
(make-provide-frame
|
||||
(first pair)
|
||||
(nth pair 1)
|
||||
(list)
|
||||
env)
|
||||
kont))))))
|
||||
|
||||
(define
|
||||
@@ -406,14 +404,6 @@
|
||||
true
|
||||
(has-reactive-reset-frame? (rest kont))))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 5: Evaluation Utilities
|
||||
;;
|
||||
;; Forward-declared eval-expr, lambda/component calling, keyword
|
||||
;; arg parsing, special form constructors (lambda, defcomp,
|
||||
;; defmacro, quasiquote), and macro expansion.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Forward declaration — redefined at end of file as CEK entry point
|
||||
(define
|
||||
kont-capture-to-reactive-reset
|
||||
(fn
|
||||
@@ -433,31 +423,39 @@
|
||||
(scan (rest k) (append captured (list frame))))))))
|
||||
(scan kont (list))))
|
||||
|
||||
;; Shared param binding for lambda/component calls.
|
||||
;; Handles &rest collection — used by both call-lambda and continue-with-call.
|
||||
(define *custom-special-forms* (dict))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 5: Evaluation Utilities
|
||||
;;
|
||||
;; Forward-declared eval-expr, lambda/component calling, keyword
|
||||
;; arg parsing, special form constructors (lambda, defcomp,
|
||||
;; defmacro, quasiquote), and macro expansion.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Forward declaration — redefined at end of file as CEK entry point
|
||||
(define
|
||||
register-special-form!
|
||||
(fn
|
||||
((name :as string) handler)
|
||||
(dict-set! *custom-special-forms* name handler)))
|
||||
|
||||
;; Component calls: parse keyword args, bind params, TCO thunk
|
||||
;; Shared param binding for lambda/component calls.
|
||||
;; Handles &rest collection — used by both call-lambda and continue-with-call.
|
||||
(define *render-check* nil)
|
||||
|
||||
(define *render-fn* nil)
|
||||
|
||||
;; Cond/case helpers
|
||||
;; Component calls: parse keyword args, bind params, TCO thunk
|
||||
(define *bind-tracking* nil)
|
||||
|
||||
(define *provide-batch-depth* 0)
|
||||
|
||||
;; Special form constructors — build state for CEK evaluation
|
||||
;; Cond/case helpers
|
||||
(define *provide-batch-queue* (list))
|
||||
|
||||
(define *provide-subscribers* (dict))
|
||||
|
||||
;; Special form constructors — build state for CEK evaluation
|
||||
(define *winders* (list))
|
||||
|
||||
(define *library-registry* (dict))
|
||||
@@ -488,11 +486,11 @@
|
||||
|
||||
(define *io-registry* (dict))
|
||||
|
||||
;; Quasiquote expansion
|
||||
(define io-register! (fn (name spec) (dict-set! *io-registry* name spec)))
|
||||
|
||||
(define io-registered? (fn (name) (has-key? *io-registry* name)))
|
||||
|
||||
;; Quasiquote expansion
|
||||
(define io-lookup (fn (name) (get *io-registry* name)))
|
||||
|
||||
(define io-names (fn () (keys *io-registry*)))
|
||||
@@ -503,9 +501,13 @@
|
||||
foreign-register!
|
||||
(fn (name spec) (dict-set! *foreign-registry* name spec)))
|
||||
|
||||
;; Macro expansion — expand then re-evaluate the result
|
||||
(define foreign-registered? (fn (name) (has-key? *foreign-registry* name)))
|
||||
|
||||
(define foreign-lookup (fn (name) (get *foreign-registry* name)))
|
||||
|
||||
;; Macro expansion — expand then re-evaluate the result
|
||||
(define foreign-names (fn () (keys *foreign-registry*)))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 6: CEK Machine Core
|
||||
;;
|
||||
@@ -514,10 +516,6 @@
|
||||
;; step-eval: evaluates control expression, pushes frames.
|
||||
;; step-continue: pops a frame, processes result.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define foreign-lookup (fn (name) (get *foreign-registry* name)))
|
||||
|
||||
(define foreign-names (fn () (keys *foreign-registry*)))
|
||||
|
||||
(define
|
||||
foreign-parse-params
|
||||
(fn
|
||||
@@ -528,12 +526,6 @@
|
||||
(items (if (list? param-list) param-list (list))))
|
||||
(foreign-parse-params-loop items result))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 7: Special Form Step Functions
|
||||
;;
|
||||
;; Each step-sf-* handles one special form in the eval phase.
|
||||
;; They push frames and return new CEK states — never recurse.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define
|
||||
foreign-parse-kwargs!
|
||||
(fn
|
||||
@@ -551,7 +543,6 @@
|
||||
(if (keyword? v) (keyword-name v) v)))
|
||||
(foreign-parse-kwargs! spec (rest (rest remaining))))))
|
||||
|
||||
;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise
|
||||
(define
|
||||
foreign-resolve-binding
|
||||
(fn
|
||||
@@ -566,9 +557,12 @@
|
||||
(obj (join "." (reverse (rest (reverse parts))))))
|
||||
{:method method :object obj})))))
|
||||
|
||||
;; List evaluation — dispatches on head: special forms, macros,
|
||||
;; higher-order forms, or function calls. This is the main
|
||||
;; expression dispatcher for the CEK machine.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 7: Special Form Step Functions
|
||||
;;
|
||||
;; Each step-sf-* handles one special form in the eval phase.
|
||||
;; They push frames and return new CEK states — never recurse.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define
|
||||
foreign-check-args
|
||||
(fn
|
||||
@@ -606,7 +600,7 @@
|
||||
(type-of val))))))
|
||||
(range 0 (min (len params) (len args))))))
|
||||
|
||||
;; call/cc: capture entire kont as undelimited escape continuation
|
||||
;; R7RS guard: desugars to call/cc + handler-bind with sentinel re-raise
|
||||
(define
|
||||
foreign-build-lambda
|
||||
(fn
|
||||
@@ -639,6 +633,9 @@
|
||||
(list (quote quote) name)
|
||||
(quote __ffi-args__)))))))
|
||||
|
||||
;; List evaluation — dispatches on head: special forms, macros,
|
||||
;; higher-order forms, or function calls. This is the main
|
||||
;; expression dispatcher for the CEK machine.
|
||||
(define
|
||||
sf-define-foreign
|
||||
(fn
|
||||
@@ -653,6 +650,7 @@
|
||||
(foreign-register! name spec)
|
||||
spec)))
|
||||
|
||||
;; call/cc: capture entire kont as undelimited escape continuation
|
||||
(define
|
||||
step-sf-define-foreign
|
||||
(fn
|
||||
@@ -670,7 +668,6 @@
|
||||
env
|
||||
(kont-push (make-define-foreign-frame name spec env) kont)))))
|
||||
|
||||
;; Pattern matching (match form)
|
||||
(define
|
||||
foreign-dispatch
|
||||
(fn
|
||||
@@ -708,7 +705,6 @@
|
||||
name
|
||||
": host-call not available on this platform")))))))))
|
||||
|
||||
;; Condition system special forms
|
||||
(define
|
||||
foreign-parse-params-loop
|
||||
(fn
|
||||
@@ -731,6 +727,7 @@
|
||||
rest-items
|
||||
(append acc (list {:type "any" :name (if (symbol? item) (symbol-name item) (str item))}))))))))
|
||||
|
||||
;; Pattern matching (match form)
|
||||
(define
|
||||
step-sf-io
|
||||
(fn
|
||||
@@ -743,6 +740,7 @@
|
||||
(str "io: unknown operation '" name "' — not in *io-registry*")))
|
||||
(make-cek-state (cons (quote perform) (list {:args io-args :op name})) env kont))))
|
||||
|
||||
;; Condition system special forms
|
||||
(define
|
||||
trampoline
|
||||
(fn
|
||||
@@ -786,7 +784,10 @@
|
||||
(nil? val)
|
||||
(value-matches-type?
|
||||
val
|
||||
(slice expected-type 0 (- (string-length expected-type) 1))))
|
||||
(slice
|
||||
expected-type
|
||||
0
|
||||
(- (string-length expected-type) 1))))
|
||||
true)))))
|
||||
|
||||
(define
|
||||
@@ -985,7 +986,6 @@
|
||||
(= (type-of test) "symbol")
|
||||
(or (= (symbol-name test) "else") (= (symbol-name test) ":else"))))))
|
||||
|
||||
;; Scope/provide/context — structured downward data passing
|
||||
(define
|
||||
sf-named-let
|
||||
(fn
|
||||
@@ -1018,7 +1018,9 @@
|
||||
(append!
|
||||
params
|
||||
(if
|
||||
(= (type-of (nth bindings (* pair-idx 2))) "symbol")
|
||||
(=
|
||||
(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))))))
|
||||
@@ -1062,6 +1064,7 @@
|
||||
params-expr)))
|
||||
(make-lambda param-names body env))))
|
||||
|
||||
;; Scope/provide/context — structured downward data passing
|
||||
(define
|
||||
sf-defcomp
|
||||
(fn
|
||||
@@ -1121,18 +1124,6 @@
|
||||
(range 2 end 1))
|
||||
result)))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; R7RS syntax-rules / define-syntax
|
||||
;;
|
||||
;; syntax-rules creates a macro transformer via pattern matching.
|
||||
;; define-syntax binds the transformer as a macro (reuses define).
|
||||
;; Pattern language: _ (wildcard), literals (exact match),
|
||||
;; pattern variables (bind), ... (ellipsis/repetition).
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
|
||||
;; Match a syntax-rules pattern against a form.
|
||||
;; Returns a dict of bindings on success, nil on failure.
|
||||
;; literals is a list of symbol name strings that must match exactly.
|
||||
(define
|
||||
parse-comp-params
|
||||
(fn
|
||||
@@ -1179,8 +1170,6 @@
|
||||
params-expr)
|
||||
(list params has-children param-types))))
|
||||
|
||||
;; Match a list pattern against a form list, handling ellipsis at any position.
|
||||
;; pi = pattern index, fi = form index.
|
||||
(define
|
||||
sf-defisland
|
||||
(fn
|
||||
@@ -1206,8 +1195,18 @@
|
||||
(env-bind! env (symbol-name name-sym) island)
|
||||
island))))
|
||||
|
||||
;; Find which pattern variable in a template drives an ellipsis.
|
||||
;; Returns the variable name (string) whose binding is a list, or nil.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; R7RS syntax-rules / define-syntax
|
||||
;;
|
||||
;; syntax-rules creates a macro transformer via pattern matching.
|
||||
;; define-syntax binds the transformer as a macro (reuses define).
|
||||
;; Pattern language: _ (wildcard), literals (exact match),
|
||||
;; pattern variables (bind), ... (ellipsis/repetition).
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
|
||||
;; Match a syntax-rules pattern against a form.
|
||||
;; Returns a dict of bindings on success, nil on failure.
|
||||
;; literals is a list of symbol name strings that must match exactly.
|
||||
(define
|
||||
defio-parse-kwargs!
|
||||
(fn
|
||||
@@ -1217,11 +1216,14 @@
|
||||
(not (empty? remaining))
|
||||
(>= (len remaining) 2)
|
||||
(keyword? (first remaining)))
|
||||
(dict-set! spec (keyword-name (first remaining)) (nth remaining 1))
|
||||
(dict-set!
|
||||
spec
|
||||
(keyword-name (first remaining))
|
||||
(nth remaining 1))
|
||||
(defio-parse-kwargs! spec (rest (rest remaining))))))
|
||||
|
||||
;; Find ALL ellipsis-bound pattern variables in a template.
|
||||
;; Returns a list of variable name strings.
|
||||
;; Match a list pattern against a form list, handling ellipsis at any position.
|
||||
;; pi = pattern index, fi = form index.
|
||||
(define
|
||||
sf-defio
|
||||
(fn
|
||||
@@ -1233,8 +1235,8 @@
|
||||
(io-register! name spec)
|
||||
spec)))
|
||||
|
||||
;; Instantiate a template with pattern variable bindings.
|
||||
;; Handles ellipsis repetition and recursive substitution.
|
||||
;; Find which pattern variable in a template drives an ellipsis.
|
||||
;; Returns the variable name (string) whose binding is a list, or nil.
|
||||
(define
|
||||
sf-defmacro
|
||||
(fn
|
||||
@@ -1251,9 +1253,8 @@
|
||||
(env-bind! env (symbol-name name-sym) mac)
|
||||
mac))))
|
||||
|
||||
;; Walk a template list, handling ellipsis at any position.
|
||||
;; When element at i is followed by ... at i+1, expand the element
|
||||
;; for each value of its ellipsis variables (all cycled in parallel).
|
||||
;; Find ALL ellipsis-bound pattern variables in a template.
|
||||
;; Returns a list of variable name strings.
|
||||
(define
|
||||
parse-macro-params
|
||||
(fn
|
||||
@@ -1282,10 +1283,8 @@
|
||||
params-expr)
|
||||
(list params rest-param))))
|
||||
|
||||
;; Try each syntax-rules clause against a form.
|
||||
;; Returns the instantiated template for the first matching rule, or errors.
|
||||
;; form is the raw args (without macro name). We prepend a dummy _ symbol
|
||||
;; because syntax-rules patterns include the keyword as the first element.
|
||||
;; Instantiate a template with pattern variable bindings.
|
||||
;; Handles ellipsis repetition and recursive substitution.
|
||||
(define
|
||||
qq-expand
|
||||
(fn
|
||||
@@ -1325,6 +1324,9 @@
|
||||
(list)
|
||||
template)))))))
|
||||
|
||||
;; Walk a template list, handling ellipsis at any position.
|
||||
;; When element at i is followed by ... at i+1, expand the element
|
||||
;; for each value of its ellipsis variables (all cycled in parallel).
|
||||
(define
|
||||
sf-letrec
|
||||
(fn
|
||||
@@ -1380,10 +1382,10 @@
|
||||
(slice body 0 (dec (len body))))
|
||||
(make-thunk (last body) local))))
|
||||
|
||||
;; Special form: (syntax-rules (literal ...) (pattern template) ...)
|
||||
;; Creates a Macro with rules/literals stored in closure env.
|
||||
;; Body is a marker symbol; expand-macro detects it and calls
|
||||
;; the pattern matcher directly.
|
||||
;; Try each syntax-rules clause against a form.
|
||||
;; Returns the instantiated template for the first matching rule, or errors.
|
||||
;; form is the raw args (without macro name). We prepend a dummy _ symbol
|
||||
;; because syntax-rules patterns include the keyword as the first element.
|
||||
(define
|
||||
call-with-values
|
||||
(fn
|
||||
@@ -1425,17 +1427,10 @@
|
||||
body)
|
||||
last-val))))
|
||||
|
||||
;; R7RS records (SRFI-9)
|
||||
;;
|
||||
;; (define-record-type <point>
|
||||
;; (make-point x y)
|
||||
;; point?
|
||||
;; (x point-x)
|
||||
;; (y point-y set-point-y!))
|
||||
;;
|
||||
;; Creates: constructor, predicate, accessors, optional mutators.
|
||||
;; Opaque — only accessible through generated functions.
|
||||
;; Generative — each call creates a unique type.
|
||||
;; Special form: (syntax-rules (literal ...) (pattern template) ...)
|
||||
;; Creates a Macro with rules/literals stored in closure env.
|
||||
;; Body is a marker symbol; expand-macro detects it and calls
|
||||
;; the pattern matcher directly.
|
||||
(define
|
||||
sf-define-values
|
||||
(fn
|
||||
@@ -1451,12 +1446,22 @@
|
||||
names)
|
||||
nil)))))
|
||||
|
||||
;; Delimited continuations
|
||||
(register-special-form! "define-values" sf-define-values)
|
||||
|
||||
;; R7RS records (SRFI-9)
|
||||
;;
|
||||
;; (define-record-type <point>
|
||||
;; (make-point x y)
|
||||
;; point?
|
||||
;; (x point-x)
|
||||
;; (y point-y set-point-y!))
|
||||
;;
|
||||
;; Creates: constructor, predicate, accessors, optional mutators.
|
||||
;; Opaque — only accessible through generated functions.
|
||||
;; Generative — each call creates a unique type.
|
||||
(register-special-form! "let-values" sf-let-values)
|
||||
|
||||
;; Signal dereferencing with reactive dependency tracking
|
||||
;; Delimited continuations
|
||||
(define
|
||||
step-sf-letrec
|
||||
(fn
|
||||
@@ -1465,13 +1470,6 @@
|
||||
((thk (sf-letrec args env)))
|
||||
(make-cek-state (thunk-expr thk) (thunk-env thk) kont))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 8: Call Dispatch
|
||||
;;
|
||||
;; cek-call: invoke a function from native code (runs a nested
|
||||
;; trampoline). step-eval-call: CEK-native call dispatch for
|
||||
;; lambda, component, native fn, and continuations.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define
|
||||
step-sf-dynamic-wind
|
||||
(fn
|
||||
@@ -1492,7 +1490,7 @@
|
||||
(list)
|
||||
(kont-push (make-wind-after-frame after winders-len env) kont)))))))
|
||||
|
||||
;; Reactive signal tracking — captures dependency continuation for re-render
|
||||
;; Signal dereferencing with reactive dependency tracking
|
||||
(define
|
||||
sf-scope
|
||||
(fn
|
||||
@@ -1520,6 +1518,13 @@
|
||||
(scope-pop! name)
|
||||
result))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 8: Call Dispatch
|
||||
;;
|
||||
;; cek-call: invoke a function from native code (runs a nested
|
||||
;; trampoline). step-eval-call: CEK-native call dispatch for
|
||||
;; lambda, component, native fn, and continuations.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define
|
||||
sf-provide
|
||||
(fn
|
||||
@@ -1536,13 +1541,7 @@
|
||||
(scope-pop! name)
|
||||
result)))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 9: Higher-Order Form Machinery
|
||||
;;
|
||||
;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
|
||||
;; ho-swap-args auto-detects argument order. HoSetupFrame stages
|
||||
;; argument evaluation, then dispatches to the appropriate step-ho-*.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Reactive signal tracking — captures dependency continuation for re-render
|
||||
(define
|
||||
expand-macro
|
||||
(fn
|
||||
@@ -1587,6 +1586,13 @@
|
||||
state
|
||||
(cek-step-loop (cek-step state)))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 9: Higher-Order Form Machinery
|
||||
;;
|
||||
;; Data-first HO forms: (map coll fn) and (map fn coll) both work.
|
||||
;; ho-swap-args auto-detects argument order. HoSetupFrame stages
|
||||
;; argument evaluation, then dispatches to the appropriate step-ho-*.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define
|
||||
cek-run
|
||||
(fn
|
||||
@@ -1789,14 +1795,6 @@
|
||||
env
|
||||
kont))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 10: Continue Phase — Frame Dispatch
|
||||
;;
|
||||
;; When phase="continue", pop the top frame and process the value.
|
||||
;; Each frame type has its own handling: if frames check truthiness,
|
||||
;; let frames bind the value, arg frames accumulate it, etc.
|
||||
;; continue-with-call handles the final function/component dispatch.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define
|
||||
step-eval-list
|
||||
(fn
|
||||
@@ -1974,9 +1972,6 @@
|
||||
:else (step-eval-call head args env kont)))))
|
||||
(step-eval-call head args env kont))))))
|
||||
|
||||
;; Final call dispatch from arg frame — all args evaluated, invoke function.
|
||||
;; Handles: lambda (bind params + TCO), component (keyword args + TCO),
|
||||
;; native fn (direct call), continuation (resume), callcc continuation (escape).
|
||||
(define
|
||||
sf-define-type
|
||||
(fn
|
||||
@@ -2036,19 +2031,23 @@
|
||||
ctor-specs)
|
||||
nil))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 10: Continue Phase — Frame Dispatch
|
||||
;;
|
||||
;; When phase="continue", pop the top frame and process the value.
|
||||
;; Each frame type has its own handling: if frames check truthiness,
|
||||
;; let frames bind the value, arg frames accumulate it, etc.
|
||||
;; continue-with-call handles the final function/component dispatch.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define
|
||||
sf-delay
|
||||
(fn
|
||||
(args env)
|
||||
(let ((thunk (make-lambda (list) (first args) env))) {:forced false :value nil :thunk thunk :_promise true})))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 11: Entry Points
|
||||
;;
|
||||
;; eval-expr-cek / trampoline-cek: CEK evaluation entry points.
|
||||
;; eval-expr / trampoline: top-level bindings that override the
|
||||
;; forward declarations from Part 5.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Final call dispatch from arg frame — all args evaluated, invoke function.
|
||||
;; Handles: lambda (bind params + TCO), component (keyword args + TCO),
|
||||
;; native fn (direct call), continuation (resume), callcc continuation (escape).
|
||||
(define
|
||||
sf-delay-force
|
||||
(fn
|
||||
@@ -2057,6 +2056,13 @@
|
||||
|
||||
(define promise? (fn (v) (and (dict? v) (get v :_promise false))))
|
||||
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
;; Part 11: Entry Points
|
||||
;;
|
||||
;; eval-expr-cek / trampoline-cek: CEK evaluation entry points.
|
||||
;; eval-expr / trampoline: top-level bindings that override the
|
||||
;; forward declarations from Part 5.
|
||||
;; ═══════════════════════════════════════════════════════════════
|
||||
(define make-promise (fn (v) {:forced true :value v :_promise true}))
|
||||
|
||||
(define
|
||||
@@ -3484,6 +3490,30 @@
|
||||
((a (first evaled)) (b (nth evaled 1)))
|
||||
(if (and (not (ho-fn? a)) (ho-fn? b)) (list b a) evaled)))))
|
||||
|
||||
(define
|
||||
seq-to-list
|
||||
(fn
|
||||
(x)
|
||||
(cond
|
||||
((= x nil) (list))
|
||||
((list? x) x)
|
||||
((vector? x) (vector->list x))
|
||||
((string? x)
|
||||
(let
|
||||
((n (len x)))
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
(i acc)
|
||||
(if
|
||||
(< i 0)
|
||||
acc
|
||||
(loop
|
||||
(- i 1)
|
||||
(cons (slice x i (+ i 1)) acc)))))
|
||||
(loop (- n 1) (list))))
|
||||
(else x))))
|
||||
|
||||
(define
|
||||
ho-setup-dispatch
|
||||
(fn
|
||||
@@ -3514,7 +3544,7 @@
|
||||
(make-multi-map-frame f tails (list) env)
|
||||
kont)))))
|
||||
(let
|
||||
((coll (nth ordered 1)))
|
||||
((coll (seq-to-list (nth ordered 1))))
|
||||
(if
|
||||
(empty? coll)
|
||||
(make-cek-value (list) env kont)
|
||||
@@ -3528,7 +3558,7 @@
|
||||
kont))))))
|
||||
("map-indexed"
|
||||
(let
|
||||
((coll (nth ordered 1)))
|
||||
((coll (seq-to-list (nth ordered 1))))
|
||||
(if
|
||||
(empty? coll)
|
||||
(make-cek-value (list) env kont)
|
||||
@@ -3542,7 +3572,7 @@
|
||||
kont)))))
|
||||
("filter"
|
||||
(let
|
||||
((coll (nth ordered 1)))
|
||||
((coll (seq-to-list (nth ordered 1))))
|
||||
(if
|
||||
(empty? coll)
|
||||
(make-cek-value (list) env kont)
|
||||
@@ -3562,7 +3592,7 @@
|
||||
("reduce"
|
||||
(let
|
||||
((init (nth ordered 1))
|
||||
(coll (nth ordered 2)))
|
||||
(coll (seq-to-list (nth ordered 2))))
|
||||
(if
|
||||
(empty? coll)
|
||||
(make-cek-value init env kont)
|
||||
@@ -3574,7 +3604,7 @@
|
||||
(kont-push (make-reduce-frame f (rest coll) env) kont)))))
|
||||
("some"
|
||||
(let
|
||||
((coll (nth ordered 1)))
|
||||
((coll (seq-to-list (nth ordered 1))))
|
||||
(if
|
||||
(empty? coll)
|
||||
(make-cek-value false env kont)
|
||||
@@ -3586,7 +3616,7 @@
|
||||
(kont-push (make-some-frame f (rest coll) env) kont)))))
|
||||
("every"
|
||||
(let
|
||||
((coll (nth ordered 1)))
|
||||
((coll (seq-to-list (nth ordered 1))))
|
||||
(if
|
||||
(empty? coll)
|
||||
(make-cek-value true env kont)
|
||||
@@ -3598,7 +3628,7 @@
|
||||
(kont-push (make-every-frame f (rest coll) env) kont)))))
|
||||
("for-each"
|
||||
(let
|
||||
((coll (nth ordered 1)))
|
||||
((coll (seq-to-list (nth ordered 1))))
|
||||
(if
|
||||
(empty? coll)
|
||||
(make-cek-value nil env kont)
|
||||
@@ -3610,6 +3640,63 @@
|
||||
(kont-push (make-for-each-frame f (rest coll) env) kont)))))
|
||||
(_ (error (str "Unknown HO type: " ho-type))))))))
|
||||
|
||||
(define sequence-to-list (fn (s) (seq-to-list s)))
|
||||
|
||||
(define sequence-to-vector (fn (s) (list->vector (seq-to-list s))))
|
||||
|
||||
(define
|
||||
sequence-length
|
||||
(fn
|
||||
(s)
|
||||
(cond
|
||||
((or (= s nil) (list? s)) (len s))
|
||||
((vector? s) (vector-length s))
|
||||
((string? s) (len s))
|
||||
(else (len (seq-to-list s))))))
|
||||
|
||||
(define
|
||||
sequence-ref
|
||||
(fn
|
||||
(s i)
|
||||
(cond
|
||||
((or (= s nil) (list? s)) (nth s i))
|
||||
((vector? s) (vector-ref s i))
|
||||
((string? s) (slice s i (+ i 1)))
|
||||
(else (nth (seq-to-list s) i)))))
|
||||
|
||||
(define
|
||||
sequence-append
|
||||
(fn
|
||||
(s1 s2)
|
||||
(cond
|
||||
((and (vector? s1) (vector? s2))
|
||||
(list->vector (concat (vector->list s1) (vector->list s2))))
|
||||
((and (string? s1) (string? s2)) (str s1 s2))
|
||||
(else (concat (seq-to-list s1) (seq-to-list s2))))))
|
||||
|
||||
(define
|
||||
in-range
|
||||
(fn
|
||||
(a &rest rest)
|
||||
(let
|
||||
((end (if (empty? rest) a (first rest)))
|
||||
(step
|
||||
(if (>= (len rest) 2) (nth rest 1) 1))
|
||||
(real-start (if (empty? rest) 0 a)))
|
||||
(if
|
||||
(= step 0)
|
||||
(error "in-range: step cannot be zero")
|
||||
(do
|
||||
(define
|
||||
build
|
||||
(fn
|
||||
(i acc)
|
||||
(if
|
||||
(if (> step 0) (>= i end) (<= i end))
|
||||
(reverse acc)
|
||||
(build (+ i step) (cons i acc)))))
|
||||
(build real-start (list)))))))
|
||||
|
||||
(define
|
||||
step-ho-map
|
||||
(fn
|
||||
|
||||
Reference in New Issue
Block a user