giles
a90f56e3f3
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
(dynamic-wind BEFORE THUNK AFTER)
- Calls BEFORE; runs THUNK; calls AFTER; returns THUNK's value.
- If THUNK raises, AFTER still runs before the raise propagates.
- Implementation: outcome-sentinel pattern (same trick as guard
and with-exception-handler) — catch THUNK's raise inside a
host guard, run AFTER unconditionally, then either return the
value or re-raise outside the catch.
Not implemented: call/cc-escape tracking. R7RS specifies that
dynamic-wind's BEFORE and AFTER thunks should re-run when control
re-enters or exits the dynamic extent via continuations. That
requires explicit dynamic-extent stack tracking, deferred until
a consumer needs it (probably never needed for pure-eval Scheme
programs; matters for first-class-continuation-heavy code).
5 tests: success ordering, return value, after-on-raise,
raise propagation, nested wind.
237 total Scheme tests now (62 + 23 + 49 + 78 + 25).
616 lines
19 KiB
Plaintext
616 lines
19 KiB
Plaintext
;; lib/scheme/runtime.sx — R7RS-small standard environment.
|
|
;;
|
|
;; Builds scheme-standard-env from scheme-make-env, populating it with
|
|
;; arithmetic, comparison, type predicates, list/pair/vector/string/char
|
|
;; primitives, and the higher-order combinators (map/filter/fold).
|
|
;;
|
|
;; Primitives are bound as SX fns taking a list of evaluated arguments.
|
|
;; Combinators that re-enter the evaluator (map, filter, fold, apply,
|
|
;; for-each) call `scheme-apply` directly on user-supplied procedures.
|
|
;;
|
|
;; Public API
|
|
;; (scheme-standard-env) — fresh env with the full R7RS-base surface
|
|
;;
|
|
;; Consumes: lib/scheme/eval.sx (scheme-apply, scheme-make-env,
|
|
;; scheme-env-bind!, scheme-string?, scheme-char?,
|
|
;; scheme-vector?, scheme-vector-elements,
|
|
;; scheme-string-value, scheme-char-value,
|
|
;; scheme-string-make, scheme-char-make,
|
|
;; scheme-vector-make).
|
|
|
|
;; ── Arity / fold helpers ─────────────────────────────────────────
|
|
|
|
(define
|
|
scm-unary
|
|
(fn
|
|
(name f)
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((not (= (length args) 1))
|
|
(error (str name ": expects 1 argument")))
|
|
(:else (f (first args)))))))
|
|
|
|
(define
|
|
scm-binary
|
|
(fn
|
|
(name f)
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(error (str name ": expects 2 arguments")))
|
|
(:else (f (first args) (nth args 1)))))))
|
|
|
|
;; Variadic left-fold helper. zero-id is the identity (`(+)` → 0).
|
|
;; one-fn handles single-arg case (`(- x)` negates).
|
|
(define
|
|
scm-fold-step
|
|
(fn
|
|
(f acc rest-args)
|
|
(cond
|
|
((or (nil? rest-args) (= (length rest-args) 0)) acc)
|
|
(:else (scm-fold-step f (f acc (first rest-args)) (rest rest-args))))))
|
|
|
|
(define
|
|
scm-fold
|
|
(fn
|
|
(name f zero-id one-fn)
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((= (length args) 0) zero-id)
|
|
((= (length args) 1) (one-fn (first args)))
|
|
(:else (scm-fold-step f (first args) (rest args)))))))
|
|
|
|
;; n-ary chained comparison: (< 1 2 3) ≡ (< 1 2) ∧ (< 2 3).
|
|
(define
|
|
scm-chain-step
|
|
(fn
|
|
(cmp prev rest-args)
|
|
(cond
|
|
((or (nil? rest-args) (= (length rest-args) 0)) true)
|
|
(:else
|
|
(let
|
|
((next (first rest-args)))
|
|
(cond
|
|
((cmp prev next) (scm-chain-step cmp next (rest rest-args)))
|
|
(:else false)))))))
|
|
|
|
(define
|
|
scm-chain
|
|
(fn
|
|
(name cmp)
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((< (length args) 2)
|
|
(error (str name ": expects at least 2 arguments")))
|
|
(:else (scm-chain-step cmp (first args) (rest args)))))))
|
|
|
|
;; ── List helpers ─────────────────────────────────────────────────
|
|
|
|
(define
|
|
scm-list-append
|
|
(fn
|
|
(xs ys)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) ys)
|
|
(:else (cons (first xs) (scm-list-append (rest xs) ys))))))
|
|
|
|
(define
|
|
scm-list-reverse-step
|
|
(fn
|
|
(xs acc)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) acc)
|
|
(:else (scm-list-reverse-step (rest xs) (cons (first xs) acc))))))
|
|
|
|
(define
|
|
scm-all-lists?
|
|
(fn
|
|
(xs)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) true)
|
|
((list? (first xs)) (scm-all-lists? (rest xs)))
|
|
(:else false))))
|
|
|
|
(define
|
|
scm-append-all
|
|
(fn
|
|
(lists)
|
|
(cond
|
|
((or (nil? lists) (= (length lists) 0)) (list))
|
|
((= (length lists) 1) (first lists))
|
|
(:else (scm-list-append (first lists) (scm-append-all (rest lists)))))))
|
|
|
|
;; ── Map / Filter / Fold ──────────────────────────────────────────
|
|
;; These call scheme-apply directly so closures and primitives both work.
|
|
|
|
(define
|
|
scm-map-step
|
|
(fn
|
|
(proc xs)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) (list))
|
|
(:else
|
|
(cons
|
|
(scheme-apply proc (list (first xs)))
|
|
(scm-map-step proc (rest xs)))))))
|
|
|
|
(define
|
|
scm-filter-step
|
|
(fn
|
|
(pred xs)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) (list))
|
|
(:else
|
|
(let
|
|
((keep? (scheme-apply pred (list (first xs)))))
|
|
(cond
|
|
((not (= keep? false))
|
|
(cons (first xs) (scm-filter-step pred (rest xs))))
|
|
(:else (scm-filter-step pred (rest xs)))))))))
|
|
|
|
(define
|
|
scm-fold-left-step
|
|
(fn
|
|
(proc acc xs)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) acc)
|
|
(:else
|
|
(scm-fold-left-step
|
|
proc
|
|
(scheme-apply proc (list acc (first xs)))
|
|
(rest xs))))))
|
|
|
|
(define
|
|
scm-fold-right-step
|
|
(fn
|
|
(proc init xs)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) init)
|
|
(:else
|
|
(scheme-apply
|
|
proc
|
|
(list (first xs) (scm-fold-right-step proc init (rest xs))))))))
|
|
|
|
(define
|
|
scm-for-each-step
|
|
(fn
|
|
(proc xs)
|
|
(cond
|
|
((or (nil? xs) (= (length xs) 0)) nil)
|
|
(:else
|
|
(begin
|
|
(scheme-apply proc (list (first xs)))
|
|
(scm-for-each-step proc (rest xs)))))))
|
|
|
|
;; ── Vector helpers ──────────────────────────────────────────────
|
|
|
|
(define
|
|
scm-make-vector-step
|
|
(fn
|
|
(n fill acc)
|
|
(cond
|
|
((<= n 0) acc)
|
|
(:else (scm-make-vector-step (- n 1) fill (cons fill acc))))))
|
|
|
|
;; ── Standard env ─────────────────────────────────────────────────
|
|
|
|
(define
|
|
scheme-standard-env
|
|
(fn
|
|
()
|
|
(let
|
|
((env (scheme-make-env)))
|
|
(scheme-env-bind!
|
|
env
|
|
"+"
|
|
(scm-fold "+" (fn (a b) (+ a b)) 0 (fn (x) x)))
|
|
(scheme-env-bind!
|
|
env
|
|
"-"
|
|
(scm-fold
|
|
"-"
|
|
(fn (a b) (- a b))
|
|
0
|
|
(fn (x) (- 0 x))))
|
|
(scheme-env-bind!
|
|
env
|
|
"*"
|
|
(scm-fold "*" (fn (a b) (* a b)) 1 (fn (x) x)))
|
|
(scheme-env-bind!
|
|
env
|
|
"/"
|
|
(scm-fold
|
|
"/"
|
|
(fn (a b) (/ a b))
|
|
1
|
|
(fn (x) (/ 1 x))))
|
|
(scheme-env-bind!
|
|
env
|
|
"abs"
|
|
(scm-unary
|
|
"abs"
|
|
(fn (n) (if (< n 0) (- 0 n) n))))
|
|
(scheme-env-bind!
|
|
env
|
|
"min"
|
|
(scm-fold "min" (fn (a b) (if (< a b) a b)) nil (fn (x) x)))
|
|
(scheme-env-bind!
|
|
env
|
|
"max"
|
|
(scm-fold "max" (fn (a b) (if (< a b) b a)) nil (fn (x) x)))
|
|
(scheme-env-bind!
|
|
env
|
|
"modulo"
|
|
(scm-binary "modulo" (fn (a b) (- a (* b (floor (/ a b)))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"quotient"
|
|
(scm-binary "quotient" (fn (a b) (floor (/ a b)))))
|
|
(scheme-env-bind!
|
|
env
|
|
"remainder"
|
|
(scm-binary "remainder" (fn (a b) (- a (* b (floor (/ a b)))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"zero?"
|
|
(scm-unary "zero?" (fn (n) (= n 0))))
|
|
(scheme-env-bind!
|
|
env
|
|
"positive?"
|
|
(scm-unary "positive?" (fn (n) (> n 0))))
|
|
(scheme-env-bind!
|
|
env
|
|
"negative?"
|
|
(scm-unary "negative?" (fn (n) (< n 0))))
|
|
(scheme-env-bind! env "=" (scm-chain "=" (fn (a b) (= a b))))
|
|
(scheme-env-bind! env "<" (scm-chain "<" (fn (a b) (< a b))))
|
|
(scheme-env-bind! env ">" (scm-chain ">" (fn (a b) (> a b))))
|
|
(scheme-env-bind! env "<=" (scm-chain "<=" (fn (a b) (<= a b))))
|
|
(scheme-env-bind! env ">=" (scm-chain ">=" (fn (a b) (>= a b))))
|
|
(scheme-env-bind!
|
|
env
|
|
"number?"
|
|
(scm-unary "number?" (fn (v) (number? v))))
|
|
(scheme-env-bind!
|
|
env
|
|
"boolean?"
|
|
(scm-unary "boolean?" (fn (v) (boolean? v))))
|
|
(scheme-env-bind!
|
|
env
|
|
"symbol?"
|
|
(scm-unary "symbol?" (fn (v) (string? v))))
|
|
(scheme-env-bind!
|
|
env
|
|
"string?"
|
|
(scm-unary "string?" (fn (v) (scheme-string? v))))
|
|
(scheme-env-bind!
|
|
env
|
|
"char?"
|
|
(scm-unary "char?" (fn (v) (scheme-char? v))))
|
|
(scheme-env-bind!
|
|
env
|
|
"vector?"
|
|
(scm-unary "vector?" (fn (v) (scheme-vector? v))))
|
|
(scheme-env-bind!
|
|
env
|
|
"null?"
|
|
(scm-unary
|
|
"null?"
|
|
(fn
|
|
(v)
|
|
(or (nil? v) (and (list? v) (= (length v) 0))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"pair?"
|
|
(scm-unary
|
|
"pair?"
|
|
(fn (v) (and (list? v) (> (length v) 0)))))
|
|
(scheme-env-bind!
|
|
env
|
|
"procedure?"
|
|
(scm-unary
|
|
"procedure?"
|
|
(fn
|
|
(v)
|
|
(or
|
|
(callable? v)
|
|
(and (dict? v) (= (get v :scm-tag) :closure))))))
|
|
(scheme-env-bind! env "not" (scm-unary "not" (fn (v) (= v false))))
|
|
(scheme-env-bind!
|
|
env
|
|
"cons"
|
|
(scm-binary "cons" (fn (a b) (cons a b))))
|
|
(scheme-env-bind!
|
|
env
|
|
"car"
|
|
(scm-unary
|
|
"car"
|
|
(fn
|
|
(xs)
|
|
(cond
|
|
((or (nil? xs) (and (list? xs) (= (length xs) 0)))
|
|
(error "car: empty list"))
|
|
(:else (first xs))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"cdr"
|
|
(scm-unary
|
|
"cdr"
|
|
(fn
|
|
(xs)
|
|
(cond
|
|
((or (nil? xs) (and (list? xs) (= (length xs) 0)))
|
|
(error "cdr: empty list"))
|
|
(:else (rest xs))))))
|
|
(scheme-env-bind! env "list" (fn (args) args))
|
|
(scheme-env-bind!
|
|
env
|
|
"length"
|
|
(scm-unary "length" (fn (xs) (length xs))))
|
|
(scheme-env-bind!
|
|
env
|
|
"reverse"
|
|
(scm-unary "reverse" (fn (xs) (scm-list-reverse-step xs (list)))))
|
|
(scheme-env-bind!
|
|
env
|
|
"append"
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((scm-all-lists? args) (scm-append-all args))
|
|
(:else (error "append: all arguments must be lists")))))
|
|
(scheme-env-bind!
|
|
env
|
|
"map"
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(error "map: expects (proc list)"))
|
|
(:else (scm-map-step (first args) (nth args 1))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"filter"
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(error "filter: expects (pred list)"))
|
|
(:else (scm-filter-step (first args) (nth args 1))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"fold-left"
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((not (= (length args) 3))
|
|
(error "fold-left: expects (proc init list)"))
|
|
(:else
|
|
(scm-fold-left-step
|
|
(first args)
|
|
(nth args 1)
|
|
(nth args 2))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"fold-right"
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((not (= (length args) 3))
|
|
(error "fold-right: expects (proc init list)"))
|
|
(:else
|
|
(scm-fold-right-step
|
|
(first args)
|
|
(nth args 1)
|
|
(nth args 2))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"for-each"
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(error "for-each: expects (proc list)"))
|
|
(:else (scm-for-each-step (first args) (nth args 1))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"apply"
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(error "apply: expects (proc args-list)"))
|
|
(:else (scheme-apply (first args) (nth args 1))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"string-length"
|
|
(scm-unary
|
|
"string-length"
|
|
(fn (s) (string-length (scheme-string-value s)))))
|
|
(scheme-env-bind!
|
|
env
|
|
"string=?"
|
|
(scm-binary
|
|
"string=?"
|
|
(fn (a b) (= (scheme-string-value a) (scheme-string-value b)))))
|
|
(scheme-env-bind!
|
|
env
|
|
"string-append"
|
|
(fn
|
|
(args)
|
|
(scheme-string-make
|
|
(scm-fold-step
|
|
(fn (acc s) (str acc (scheme-string-value s)))
|
|
""
|
|
args))))
|
|
(scheme-env-bind!
|
|
env
|
|
"substring"
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((not (= (length args) 3))
|
|
(error "substring: expects (str start end)"))
|
|
(:else
|
|
(scheme-string-make
|
|
(substring
|
|
(scheme-string-value (first args))
|
|
(nth args 1)
|
|
(nth args 2)))))))
|
|
(scheme-env-bind!
|
|
env
|
|
"char=?"
|
|
(scm-binary
|
|
"char=?"
|
|
(fn (a b) (= (scheme-char-value a) (scheme-char-value b)))))
|
|
(scheme-env-bind! env "vector" (fn (args) (scheme-vector-make args)))
|
|
(scheme-env-bind!
|
|
env
|
|
"vector-length"
|
|
(scm-unary
|
|
"vector-length"
|
|
(fn (v) (length (scheme-vector-elements v)))))
|
|
(scheme-env-bind!
|
|
env
|
|
"vector-ref"
|
|
(scm-binary
|
|
"vector-ref"
|
|
(fn (v i) (nth (scheme-vector-elements v) i))))
|
|
(scheme-env-bind!
|
|
env
|
|
"vector->list"
|
|
(scm-unary "vector->list" (fn (v) (scheme-vector-elements v))))
|
|
(scheme-env-bind!
|
|
env
|
|
"list->vector"
|
|
(scm-unary "list->vector" (fn (xs) (scheme-vector-make xs))))
|
|
(scheme-env-bind!
|
|
env
|
|
"make-vector"
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((= (length args) 1)
|
|
(scheme-vector-make
|
|
(scm-make-vector-step (first args) nil (list))))
|
|
((= (length args) 2)
|
|
(scheme-vector-make
|
|
(scm-make-vector-step
|
|
(first args)
|
|
(nth args 1)
|
|
(list))))
|
|
(:else (error "make-vector: expects (n [fill])")))))
|
|
(scheme-env-bind! env "eqv?" (scm-binary "eqv?" (fn (a b) (= a b))))
|
|
(scheme-env-bind!
|
|
env
|
|
"equal?"
|
|
(scm-binary "equal?" (fn (a b) (= a b))))
|
|
(scheme-env-bind! env "eq?" (scm-binary "eq?" (fn (a b) (= a b))))
|
|
;; ── call/cc (R7RS first-class continuations) ────────────
|
|
;; Captures the host SX continuation, wraps it as a Scheme
|
|
;; procedure (fn (vargs) ...) and passes it to the user proc.
|
|
;; Calling the captured k with one value re-enters the
|
|
;; continuation; with multiple values, passes them as a list.
|
|
(scheme-env-bind! env "call/cc"
|
|
(fn (args)
|
|
(cond
|
|
((not (= (length args) 1))
|
|
(error "call/cc: expects 1 argument"))
|
|
(:else
|
|
(call/cc
|
|
(fn (k)
|
|
(let ((scheme-k
|
|
(fn (vargs)
|
|
(cond
|
|
((= (length vargs) 1) (k (first vargs)))
|
|
(:else (k vargs))))))
|
|
(scheme-apply (first args) (list scheme-k)))))))))
|
|
(scheme-env-bind! env "call-with-current-continuation"
|
|
(refl-env-lookup env "call/cc"))
|
|
;; ── R7RS exception primitives ──────────────────────────
|
|
;; raise V — raises V as exception (host SX raise).
|
|
(scheme-env-bind! env "raise"
|
|
(fn (args)
|
|
(cond
|
|
((not (= (length args) 1))
|
|
(error "raise: expects 1 argument"))
|
|
(:else (raise (first args))))))
|
|
;; error MSG IRRITANTS... — convention: raise an error-object
|
|
;; that's a dict {:scm-error MSG :irritants LIST}. The print
|
|
;; surface (error-object-message / error-object-irritants)
|
|
;; can pull these apart.
|
|
(scheme-env-bind! env "error"
|
|
(fn (args)
|
|
(cond
|
|
((= (length args) 0) (error "error: expects (message [irritant...])"))
|
|
(:else
|
|
(raise {:scm-error (cond
|
|
((scheme-string? (first args))
|
|
(scheme-string-value (first args)))
|
|
(:else (first args)))
|
|
:irritants (rest args)})))))
|
|
(scheme-env-bind! env "error-object?"
|
|
(scm-unary "error-object?"
|
|
(fn (v) (and (dict? v) (string? (get v :scm-error))))))
|
|
(scheme-env-bind! env "error-object-message"
|
|
(scm-unary "error-object-message"
|
|
(fn (v) (scheme-string-make (get v :scm-error)))))
|
|
(scheme-env-bind! env "error-object-irritants"
|
|
(scm-unary "error-object-irritants"
|
|
(fn (v) (get v :irritants))))
|
|
;; with-exception-handler HANDLER THUNK — runs THUNK; if it
|
|
;; raises, calls HANDLER with the raised value (handler can
|
|
;; itself raise or return a value). Implemented via host guard.
|
|
;; with-exception-handler — catch THUNK's raise; if caught,
|
|
;; call HANDLER. If HANDLER itself raises, propagate that to
|
|
;; the outer scope (don't re-catch in this same guard, which
|
|
;; would loop). The two-step outcome-sentinel pattern mirrors
|
|
;; the `guard` special form's escape.
|
|
(scheme-env-bind! env "with-exception-handler"
|
|
(fn (args)
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(error "with-exception-handler: expects 2 arguments"))
|
|
(:else
|
|
(let ((handler (first args))
|
|
(thunk (nth args 1)))
|
|
(let ((outcome
|
|
(guard
|
|
(e (true {:scm-weh-raised true :value e}))
|
|
(scheme-apply thunk (list)))))
|
|
(cond
|
|
((and (dict? outcome) (get outcome :scm-weh-raised))
|
|
(scheme-apply handler (list (get outcome :value))))
|
|
(:else outcome))))))))
|
|
;; dynamic-wind BEFORE THUNK AFTER — runs BEFORE, then THUNK,
|
|
;; then AFTER. If THUNK raises, AFTER still runs before the
|
|
;; raise propagates. This is the basic-correctness version;
|
|
;; proper call/cc-escape interaction would need dynamic-extent
|
|
;; tracking, deferred until needed.
|
|
(scheme-env-bind! env "dynamic-wind"
|
|
(fn (args)
|
|
(cond
|
|
((not (= (length args) 3))
|
|
(error "dynamic-wind: expects (before thunk after)"))
|
|
(:else
|
|
(let ((before-thunk (first args))
|
|
(mid-thunk (nth args 1))
|
|
(after-thunk (nth args 2)))
|
|
(begin
|
|
(scheme-apply before-thunk (list))
|
|
(let ((outcome
|
|
(guard
|
|
(e (true {:scm-dw-raised true :value e}))
|
|
(scheme-apply mid-thunk (list)))))
|
|
(begin
|
|
(scheme-apply after-thunk (list))
|
|
(cond
|
|
((and (dict? outcome) (get outcome :scm-dw-raised))
|
|
(raise (get outcome :value)))
|
|
(:else outcome))))))))))
|
|
env)))
|