Round 5: Clojure-parity concurrency + polymorphism + spec
ober
d518b0eccf42cb69893dce63d37c883b367d4925
--- a/lib/std/agent.sls +++ b/lib/std/agent.sls @@ -39,7 +39,9 @@ send send-off agent-value agent-error clear-agent-errors restart-agent - await shutdown-agent!) + await await-for shutdown-agent! + set-error-handler! set-error-mode! + agent-error-mode agent-error-handler) (import (chezscheme) (std csp) @@ -51,7 +53,9 @@ (fields (mutable val) (mutable err) (immutable action-ch) - (immutable fiber-mode?)) ;; #t if backed by fiber + (immutable fiber-mode?) ;; #t if backed by fiber + (mutable error-mode) ;; 'fail (default) | 'continue + (mutable error-handler)) ;; #f or (a exn) -> ignored (sealed #t)) (define (agent? x) (%agent? x)) @@ -74,15 +78,29 @@ (if rt ;; Fiber mode: fiber-channel + fiber worker (let* ([ch (make-fiber-channel buf-size)] - [a (make-%agent initial #f ch #t)]) + [a (make-%agent initial #f ch #t 'fail #f)]) (fiber-spawn rt (%make-fiber-worker-loop a ch)) a) ;; Thread mode: OS channel + OS thread worker (let* ([ch (make-channel buf-size)] - [a (make-%agent initial #f ch #f)]) + [a (make-%agent initial #f ch #f 'fail #f)]) (fork-thread (%make-thread-worker-loop a ch)) a)))])) + ;; --- Error policy helpers ----------------------------------- + + (define (%run-error-handler! a exn) + (let ([h (%agent-error-handler a)]) + (when h + (guard (_ [else #f]) ;; swallow handler exceptions + (h a exn))))) + + (define (%on-action-error! a exn) + (%run-error-handler! a exn) + (case (%agent-error-mode a) + [(continue) #f] ;; drop the error, keep going + [else (%agent-err-set! a exn)])) ;; 'fail — latch the error + ;; --- Worker loops ------------------------------------------- ;; OS-thread worker: blocks on chan-get! @@ -94,7 +112,7 @@ [(eof-object? action) #f] [else (unless (%agent-err a) - (guard (exn [else (%agent-err-set! a exn)]) + (guard (exn [else (%on-action-error! a exn)]) (let ([new-val (apply (car action) (%agent-val a) (cdr action))]) @@ -110,7 +128,7 @@ [(eof-object? action) #f] [else (unless (%agent-err a) - (guard (exn [else (%agent-err-set! a exn)]) + (guard (exn [else (%on-action-error! a exn)]) (let ([new-val (apply (car action) (%agent-val a) (cdr action))]) @@ -201,4 +219,70 @@ (chan-close! ch))) a) + ;; (await-for ms a) — like `await` but gives up after ms milliseconds. + ;; Returns #t if the queue drained in time, #f on timeout. + ;; Implemented by sending a marker action and polling for its completion. + (define (await-for ms a) + (unless (%agent? a) (error 'await-for "not an agent" a)) + (unless (and (integer? ms) (>= ms 0)) + (error 'await-for "ms must be a non-negative integer" ms)) + (when (%agent-err a) + (error 'await-for "agent has error; call restart-agent to clear" + (%agent-err a))) + (let ([done-box (list 'pending)] + [ch (%agent-action-ch a)]) + ;; Action that marks completion by mutating the box. + ;; Capture: cons on first slot so the caller can observe via eq?. + (let ([marker (cons (lambda (v) + (set-car! done-box 'done) + v) + '())]) + (if (%agent-fiber-mode? a) + (begin + (when (fiber-channel-closed? ch) + (error 'await-for "agent has been shut down" a)) + (fiber-channel-send ch marker)) + (begin + (when (chan-closed? ch) + (error 'await-for "agent has been shut down" a)) + (chan-put! ch marker)))) + ;; Poll for completion. 5ms steps keeps overhead low. + (let loop ([remaining ms]) + (cond + [(eq? (car done-box) 'done) #t] + [(<= remaining 0) #f] + [else + (sleep (make-time 'time-duration 5000000 0)) + (loop (- remaining 5))])))) + + ;; (set-error-handler! a fn) — install a handler called with + ;; (fn agent exception) each time an action throws. Handler runs + ;; after the action failure and before the latched-error logic. + ;; Pass #f to clear. Handler exceptions are swallowed. + (define (set-error-handler! a fn) + (unless (%agent? a) (error 'set-error-handler! "not an agent" a)) + (unless (or (not fn) (procedure? fn)) + (error 'set-error-handler! "handler must be a procedure or #f" fn)) + (%agent-error-handler-set! a fn) + a) + + ;; (set-error-mode! a mode) — mode is 'fail (default) or 'continue. + ;; In 'continue mode, action errors do not latch, so subsequent sends + ;; proceed (paired with set-error-handler! for observability). + (define (set-error-mode! a mode) + (unless (%agent? a) (error 'set-error-mode! "not an agent" a)) + (unless (memq mode '(fail continue)) + (error 'set-error-mode! "mode must be 'fail or 'continue" mode)) + (%agent-error-mode-set! a mode) + a) + + ;; Accessors (documented surface — useful for assertions/tests). + (define (agent-error-mode a) + (unless (%agent? a) (error 'agent-error-mode "not an agent" a)) + (%agent-error-mode a)) + + (define (agent-error-handler a) + (unless (%agent? a) (error 'agent-error-handler "not an agent" a)) + (%agent-error-handler a)) + ) ;; end library --- a/lib/std/misc/atom.sls +++ b/lib/std/misc/atom.sls @@ -54,6 +54,8 @@ deref reset! swap! compare-and-set! ;; ---- Watches (§4.7) ---- add-watch! remove-watch! + ;; ---- Validators (Round 5 §31) ---- + set-validator! get-validator ;; ---- Volatiles (§4.7) ---- volatile! volatile? vreset! vswap! vderef) @@ -63,11 +65,23 @@ (fields (mutable val) (immutable mtx) - (mutable watches)) ;; alist of (key . (lambda (k atom old new) ...)) + (mutable watches) ;; alist of (key . (lambda (k atom old new) ...)) + (mutable validator)) ;; either #f or a (lambda (new-val) -> truthy/false) (sealed #t)) (define (atom initial-value) - (make-atom-rec initial-value (make-mutex) '())) + (make-atom-rec initial-value (make-mutex) '() #f)) + + ;; Run validator outside the mutex so nested atom ops don't deadlock. + ;; Raises if the validator returns #f or itself raises. Called BEFORE + ;; the new value is installed (matches Clojure: invalid values never + ;; make it into the atom). + (define (%check-validator! a new-val) + (let ([v (atom-rec-validator a)]) + (when v + (guard (exn [else (error 'atom "validator threw" exn new-val)]) + (unless (v new-val) + (error 'atom "invalid state" new-val)))))) (define (atom? x) (atom-rec? x)) @@ -86,6 +100,7 @@ watches)) (define (atom-reset! a new-val) + (%check-validator! a new-val) (let-values ([(old watches) (with-mutex (atom-rec-mtx a) (let ([o (atom-rec-val a)]) @@ -96,10 +111,13 @@ (define (atom-swap! a fn) ;; Atomically apply fn to current value, store and return result. + ;; Validator runs inside the mutex (between fn and install) so + ;; a failed validation leaves the old value in place. (let-values ([(old new watches) (with-mutex (atom-rec-mtx a) (let* ([o (atom-rec-val a)] [n (fn o)]) + (%check-validator! a n) (atom-rec-val-set! a n) (values o n (atom-rec-watches a))))]) (%fire-watches! a old new watches) @@ -111,6 +129,7 @@ (with-mutex (atom-rec-mtx a) (let* ([o (atom-rec-val a)] [n (apply fn o args)]) + (%check-validator! a n) (atom-rec-val-set! a n) (values o n (atom-rec-watches a))))]) (%fire-watches! a old new watches) @@ -137,11 +156,12 @@ (define (compare-and-set! a expected new-val) ;; Atomically: if current value is equal? to expected, replace ;; with new-val and return #t. Otherwise return #f. Fires watches - ;; ONLY on successful swap. + ;; ONLY on successful swap. Validator runs inside the mutex. (let-values ([(swapped? old watches) (with-mutex (atom-rec-mtx a) (cond [(equal? (atom-rec-val a) expected) + (%check-validator! a new-val) (let ([o (atom-rec-val a)]) (atom-rec-val-set! a new-val) (values #t o (atom-rec-watches a)))] @@ -151,6 +171,40 @@ swapped?)) ;; ========================================================================= + ;; Validators (Round 5 §31) + ;; + ;; Matches Clojure semantics: the validator is a (lambda (new-val) …) + ;; predicate applied to every proposed new value before it is + ;; installed. Returning #f or raising from the validator causes the + ;; state change to fail (old value stays). set-validator! verifies + ;; the current value passes before installing the validator so an + ;; atom never holds a value its validator rejects. + ;; ========================================================================= + + (define (set-validator! a pred) + (unless (atom? a) + (error 'set-validator! "not an atom" a)) + (unless (or (not pred) (procedure? pred)) + (error 'set-validator! "validator must be a procedure or #f" pred)) + (with-mutex (atom-rec-mtx a) + (when pred + (let ([v (atom-rec-val a)]) + (guard (exn [else (error 'set-validator! + "validator rejects current value" + v)]) + (unless (pred v) + (error 'set-validator! + "validator rejects current value" + v))))) + (atom-rec-validator-set! a pred)) + a) + + (define (get-validator a) + (unless (atom? a) + (error 'get-validator "not an atom" a)) + (atom-rec-validator a)) + + ;; ========================================================================= ;; Watches (§4.7) ;; ========================================================================= --- a/lib/std/multi.sls +++ b/lib/std/multi.sls @@ -37,10 +37,155 @@ defmulti defmethod ;; Introspection / mutation multimethod? multimethod-name - get-method remove-method methods) + get-method remove-method methods + ;; Hierarchy (Round 5 §35) + make-hierarchy + derive underive + parents ancestors descendants + isa? + prefer-method preferred-methods + global-hierarchy) (import (chezscheme)) + ;; --- Hierarchy (Round 5 §35) -------------------------------- + ;; + ;; A hierarchy records user-defined `isa?` relations over arbitrary + ;; dispatch values. Clojure's default hierarchy is a shared mutable + ;; structure seeded empty and populated by `derive`. We expose both + ;; `global-hierarchy` (the default) and `make-hierarchy` for isolated + ;; hierarchies used by tests or libraries that want to avoid leaking + ;; `derive` calls into a shared table. + + (define-record-type %hierarchy + (fields (immutable parents-ht) ;; eqv? hashtable: tag -> list of direct parents + (immutable descendants-ht) ;; eqv? hashtable: tag -> list of direct children + (immutable lock)) + (sealed #t)) + + (define (make-hierarchy) + (make-%hierarchy + (make-hashtable equal-hash equal?) + (make-hashtable equal-hash equal?) + (make-mutex))) + + (define global-hierarchy (make-hierarchy)) + + (define (%parents-of h tag) + (hashtable-ref (%hierarchy-parents-ht h) tag '())) + + (define (%children-of h tag) + (hashtable-ref (%hierarchy-descendants-ht h) tag '())) + + (define (%add-once! ht k v) + (let ([cur (hashtable-ref ht k '())]) + (unless (member v cur) + (hashtable-set! ht k (cons v cur))))) + + (define (%remove-once! ht k v) + (let ([cur (hashtable-ref ht k '())]) + (hashtable-set! ht k + (filter (lambda (x) (not (equal? x v))) cur)))) + + ;; derive: register child -> parent. Accepts 2 or 3 args: + ;; (derive child parent) ;; mutates global-hierarchy + ;; (derive h child parent) ;; mutates given hierarchy + ;; Rejects cycles. + (define derive + (case-lambda + [(child parent) (derive global-hierarchy child parent)] + [(h child parent) + (unless (%hierarchy? h) + (error 'derive "not a hierarchy" h)) + (when (equal? child parent) + (error 'derive "cannot derive tag from itself" child)) + (with-mutex (%hierarchy-lock h) + (when (%isa?/locked h parent child) + (error 'derive "cycle: parent already derives from child" + (list child '-> parent))) + (%add-once! (%hierarchy-parents-ht h) child parent) + (%add-once! (%hierarchy-descendants-ht h) parent child)) + h])) + + (define underive + (case-lambda + [(child parent) (underive global-hierarchy child parent)] + [(h child parent) + (unless (%hierarchy? h) + (error 'underive "not a hierarchy" h)) + (with-mutex (%hierarchy-lock h) + (%remove-once! (%hierarchy-parents-ht h) child parent) + (%remove-once! (%hierarchy-descendants-ht h) parent child)) + h])) + + (define parents + (case-lambda + [(tag) (parents global-hierarchy tag)] + [(h tag) + (unless (%hierarchy? h) + (error 'parents "not a hierarchy" h)) + (with-mutex (%hierarchy-lock h) (%parents-of h tag))])) + + ;; Breadth-first reachable from `tag` via parents (ancestors) + ;; or descendants (children). Unique, self-excluded. + (define (%bfs step h tag) + (let loop ([frontier (step h tag)] [seen '()] [acc '()]) + (cond + [(null? frontier) (reverse acc)] + [else + (let ([t (car frontier)]) + (cond + [(member t seen) (loop (cdr frontier) seen acc)] + [else + (loop (append (cdr frontier) (step h t)) + (cons t seen) + (cons t acc))]))]))) + + (define ancestors + (case-lambda + [(tag) (ancestors global-hierarchy tag)] + [(h tag) + (unless (%hierarchy? h) + (error 'ancestors "not a hierarchy" h)) + (with-mutex (%hierarchy-lock h) + (%bfs %parents-of h tag))])) + + (define descendants + (case-lambda + [(tag) (descendants global-hierarchy tag)] + [(h tag) + (unless (%hierarchy? h) + (error 'descendants "not a hierarchy" h)) + (with-mutex (%hierarchy-lock h) + (%bfs %children-of h tag))])) + + ;; isa? — Clojure returns #t when: + ;; - x equal? y, or + ;; - y appears in the ancestor closure of x + ;; We do not model class inheritance here; for records, callers should + ;; pass the rtd as the tag if they want record-type derivation. + (define (%isa?/locked h x y) + (cond + [(equal? x y) #t] + [else + (let loop ([frontier (%parents-of h x)] [seen '()]) + (cond + [(null? frontier) #f] + [(equal? (car frontier) y) #t] + [(member (car frontier) seen) (loop (cdr frontier) seen)] + [else + (loop (append (cdr frontier) + (%parents-of h (car frontier))) + (cons (car frontier) seen))]))])) + + (define isa? + (case-lambda + [(x y) (isa? global-hierarchy x y)] + [(h x y) + (unless (%hierarchy? h) + (error 'isa? "not a hierarchy" h)) + (with-mutex (%hierarchy-lock h) (%isa?/locked h x y))])) + ;; --- Record ----------------------------------------------- ;; ;; The record is internal: user-facing `multimethod?` and @@ -54,13 +199,17 @@ (immutable dispatch-fn) (immutable methods) ;; hashtable, equal? keys (mutable default-method) - (immutable lock)) ;; guards methods + default + (immutable hierarchy) ;; %hierarchy used for isa? walks + (mutable preferences) ;; alist of (a . b) meaning prefer a over b + (immutable lock)) ;; guards methods + default + prefs (sealed #t)) (define (%new-multimethod name dispatch-fn) (make-%mm name dispatch-fn (make-hashtable equal-hash equal?) #f + global-hierarchy + '() (make-mutex))) ;; --- Registry linking procedure -> multimethod ------------ @@ -84,10 +233,18 @@ ;; --- Dispatch --------------------------------------------- + ;; Dispatch: + ;; 1. Try exact match on dispatch value. + ;; 2. Fall back to any registered method whose key is an ancestor + ;; of the dispatch value (via the multimethod's hierarchy). + ;; Multiple matches are disambiguated by `prefer-method`; + ;; remaining ambiguity raises. + ;; 3. Fall back to the default method. (define (%invoke mm args) (let* ([k (apply (%mm-dispatch-fn mm) args)] [mn (with-mutex (%mm-lock mm) (or (hashtable-ref (%mm-methods mm) k #f) + (%hierarchy-dispatch mm k) (%mm-default-method mm)))]) (cond [mn (apply mn args)] @@ -95,6 +252,70 @@ (error (%mm-name mm) "no method for dispatch value" k)]))) + ;; Inner-lock helper — assumes caller already holds (%mm-lock mm). + (define (%hierarchy-dispatch mm k) + (let ([h (%mm-hierarchy mm)]) + (let-values ([(keys _) (hashtable-entries (%mm-methods mm))]) + (with-mutex (%hierarchy-lock h) + (let ([applicable + (let loop ([i 0] [acc '()]) + (cond + [(= i (vector-length keys)) acc] + [(%isa?/locked h k (vector-ref keys i)) + (loop (+ i 1) (cons (vector-ref keys i) acc))] + [else (loop (+ i 1) acc)]))]) + (cond + [(null? applicable) #f] + [(null? (cdr applicable)) + (hashtable-ref (%mm-methods mm) (car applicable) #f)] + [else + (let ([winner (%resolve-preferences mm applicable)]) + (hashtable-ref (%mm-methods mm) winner #f))])))))) + + ;; Given ≥2 applicable dispatch keys, pick the one preferred by + ;; `prefer-method`. If no preference resolves the conflict, raise. + (define (%resolve-preferences mm applicable) + (let ([prefs (%mm-preferences mm)]) + (let loop ([cands applicable]) + (cond + [(null? (cdr cands)) (car cands)] + [(%preferred? prefs (car cands) (cadr cands)) + (loop (cons (car cands) (cddr cands)))] + [(%preferred? prefs (cadr cands) (car cands)) + (loop (cdr cands))] + [else + (error (%mm-name mm) + "multiple methods match and none is preferred" + applicable)])))) + + (define (%preferred? prefs a b) + ;; a is preferred over b iff (a . b) is reachable via prefs + ;; walked transitively. + (let loop ([frontier (list a)] [seen '()]) + (cond + [(null? frontier) #f] + [else + (let ([x (car frontier)]) + (cond + [(member x seen) (loop (cdr frontier) seen)] + [else + (let ([next (filter-map + (lambda (p) + (and (equal? (car p) x) (cdr p))) + prefs)]) + (cond + [(member b next) #t] + [else (loop (append (cdr frontier) next) + (cons x seen))]))]))]))) + + (define (filter-map f lst) + (let loop ([xs lst] [acc '()]) + (cond + [(null? xs) (reverse acc)] + [else + (let ([v (f (car xs))]) + (loop (cdr xs) (if v (cons v acc) acc)))]))) + (define (%install name dispatch-fn) (let* ([mm (%new-multimethod name dispatch-fn)] [proc (lambda args (%invoke mm args))]) @@ -196,4 +417,30 @@ (vector-ref vals i)) acc))])))))) + ;; (prefer-method mm a b) — when both a and b apply via the + ;; hierarchy, pick the method registered for `a`. Idempotent; + ;; refuses to install cycles. + (define (prefer-method proc a b) + (let ([mm (%lookup proc)]) + (unless mm + (error 'prefer-method "not a multimethod" proc)) + (when (equal? a b) + (error 'prefer-method "cannot prefer a tag over itself" a)) + (with-mutex (%mm-lock mm) + (when (%preferred? (%mm-preferences mm) b a) + (error 'prefer-method + "cycle: b is already preferred over a" + (list a '-> b))) + (let ([prefs (%mm-preferences mm)]) + (unless (member (cons a b) prefs) + (%mm-preferences-set! mm (cons (cons a b) prefs))))) + proc)) + + ;; (preferred-methods mm) => alist of preferred (a . b) pairs. + (define (preferred-methods proc) + (let ([mm (%lookup proc)]) + (unless mm + (error 'preferred-methods "not a multimethod" proc)) + (with-mutex (%mm-lock mm) (%mm-preferences mm)))) + ) ;; end library --- a/lib/std/protocol.sls +++ b/lib/std/protocol.sls @@ -62,7 +62,7 @@ (export defprotocol extend-type extend-protocol protocol? protocol-name protocol-methods - satisfies?) + satisfies? extenders extends?) (import (chezscheme)) @@ -220,4 +220,44 @@ (lambda (name) (%has-impl-for? name type-key)) (%protocol-methods p)))) + ;; (extenders PROTOCOL) + ;; + ;; Returns the list of type-keys (rtds or symbols) that have + ;; registered implementations for EVERY method in PROTOCOL. + ;; Types with partial coverage are excluded — mirrors Clojure's + ;; contract that a type either satisfies the protocol or it doesn't. + ;; Order is unspecified. + (define (extenders p) + (unless (%protocol? p) + (error 'extenders "not a protocol" p)) + (let ([methods (%protocol-methods p)]) + (with-mutex %dispatch-lock + (let-values ([(tks _) (hashtable-entries %dispatch)]) + (let loop ([i 0] [acc '()]) + (cond + [(= i (vector-length tks)) acc] + [else + (let* ([tk (vector-ref tks i)] + [inner (eq-hashtable-ref %dispatch tk #f)] + [covers-all? + (and inner + (for-all + (lambda (m) + (and (eq-hashtable-ref inner m #f) #t)) + methods))]) + (loop (+ i 1) + (if covers-all? (cons tk acc) acc)))])))))) + + ;; (extends? PROTOCOL TYPE-KEY) + ;; + ;; True iff TYPE-KEY has implementations for every method in PROTOCOL. + ;; Accepts either an rtd or a symbol; distinct from `satisfies?`, + ;; which takes an instance. + (define (extends? p type-key) + (unless (%protocol? p) + (error 'extends? "not a protocol" p)) + (for-all + (lambda (m) (%has-impl-for? m type-key)) + (%protocol-methods p))) + ) ;; end library --- a/lib/std/spec.sls +++ b/lib/std/spec.sls @@ -33,6 +33,8 @@ s-valid? s-conform s-explain s-explain-str s-assert ;; Function specs s-fdef s-check-fn + ;; Instrumentation (Round 5 §36) + s-instrument s-unstrument s-instrumented? ;; Generation (basic) s-exercise) @@ -344,23 +346,34 @@ ;; s-fdef — register a function spec ;; (s-fdef my-fn :args args-spec :ret ret-spec) + ;; + ;; The keyword alternates with the spec *expression* (evaluated at + ;; call site). We iterate by recursing the macro so that each spec + ;; is evaluated in the s-fdef's enclosing environment — storing the + ;; raw syntax would yield quoted forms that validate can't run. (define *fspec-registry* (make-hashtable equal-hash equal?)) - (define-syntax s-fdef - (syntax-rules () - [(_ name kv ...) - (hashtable-set! *fspec-registry* 'name - (parse-fspec 'kv ...))])) + (define (%fspec-entry name) + (or (hashtable-ref *fspec-registry* name #f) + (let ([e (list (cons 'args #f) (cons 'ret #f))]) + (hashtable-set! *fspec-registry* name e) + e))) - (define (parse-fspec . kvs) - (let lp ([rest kvs] [args #f] [ret #f]) - (cond - [(null? rest) (list (cons 'args args) (cons 'ret ret))] - [(eq? (car rest) ':args) - (lp (cddr rest) (cadr rest) ret)] - [(eq? (car rest) ':ret) - (lp (cddr rest) args (cadr rest))] - [else (error 'parse-fspec "unknown key" (car rest))]))) + (define (%fspec-set! name key val) + (let* ([e (%fspec-entry name)] + [slot (assq key e)]) + (when slot (set-cdr! slot val)))) + + (define-syntax s-fdef + (lambda (stx) + (syntax-case stx () + [(_ name) + #'(begin (%fspec-entry 'name) (void))] + [(_ name key spec rest ...) + (memq (syntax->datum #'key) '(:args :ret :fn)) + #'(begin + (%fspec-set! 'name 'key spec) + (s-fdef name rest ...))]))) ;; s-check-fn — validate a function against its fspec (define (s-check-fn name f sample-args) @@ -385,6 +398,75 @@ ret))]))) ;; ================================================================ + ;; Instrumentation (Round 5 §36) + ;; ================================================================ + ;; + ;; (s-instrument 'name) wraps the top-level procedure bound to NAME + ;; with an arg/ret validator derived from its s-fdef registration. + ;; (s-unstrument 'name) restores the original procedure. + ;; + ;; Limitation: only works on identifiers bound at the interactive + ;; top level (e.g. in a script or REPL). Library-interior bindings + ;; are sealed by the module system and cannot be rewired from the + ;; outside — matches Clojure's behaviour where instrumenting a + ;; symbol only affects the var indirection, not inlined call sites. + ;; + ;; Calling s-instrument on an already-instrumented name is a no-op + ;; (silently returns NAME) so scripts can make instrument calls + ;; idempotent during reload. + + (define *instrumented* (make-hashtable equal-hash equal?)) + + (define (s-instrumented? name) + (hashtable-contains? *instrumented* name)) + + (define (%lookup-fspec who name) + (or (hashtable-ref *fspec-registry* name #f) + (error who "no fspec for" name))) + + (define (%make-wrapper name original args-spec ret-spec) + (lambda args + (when args-spec + (let ([r (validate args-spec args)]) + (unless (eq? r #t) + (error name "args don't conform" r)))) + (let ([ret (apply original args)]) + (when ret-spec + (let ([r (validate ret-spec ret)]) + (unless (eq? r #t) + (error name "return doesn't conform" r)))) + ret))) + + (define (s-instrument name) + (unless (symbol? name) + (error 's-instrument "name must be a symbol" name)) + (cond + [(hashtable-contains? *instrumented* name) name] + [else + (let ([fspec (%lookup-fspec 's-instrument name)]) + (let ([original + (guard (exn [else + (error 's-instrument + "no top-level binding for name" + name)]) + (top-level-value name))]) + (unless (procedure? original) + (error 's-instrument "binding is not a procedure" name)) + (let ([args-spec (cdr (assq 'args fspec))] + [ret-spec (cdr (assq 'ret fspec))]) + (hashtable-set! *instrumented* name original) + (set-top-level-value! name + (%make-wrapper name original args-spec ret-spec)) + name)))])) + + (define (s-unstrument name) + (let ([orig (hashtable-ref *instrumented* name #f)]) + (when orig + (set-top-level-value! name orig) + (hashtable-delete! *instrumented* name)) + name)) + + ;; ================================================================ ;; Generation (basic exercise) ;; ================================================================ --- a/lib/std/stm.sls +++ b/lib/std/stm.sls @@ -40,7 +40,7 @@ ;; Clojure-style aliases make-ref ref? ref-deref - dosync alter ref-set commute ensure) + dosync alter ref-set commute ensure io!) (import (chezscheme) (std fiber)) @@ -352,4 +352,17 @@ (define (ensure r) (tvar-read r)) + ;; ========== io! — guard side-effecting code from retry ========== + ;; + ;; Clojure's io! form raises when evaluated inside a dosync, preventing + ;; callers from accidentally performing side effects that would be + ;; replayed on retry. Outside a transaction the body runs unguarded. + (define-syntax io! + (syntax-rules () + [(_ body ...) + (begin + (when (*current-tx*) + (error 'io! "io! forms are not allowed inside a transaction")) + body ...)])) + ) ;; end library --- a/tests/test-agent.ss +++ b/tests/test-agent.ss @@ -236,6 +236,110 @@ (let ([v (agent-value a)]) (shutdown-agent! a) v)) 5) +;;; ---- await-for (timeout) --------------------------------------- + +(test "await-for returns #t when queue drains in time" + (let ([a (agent 0)]) + (send a + 1) + (let ([r (await-for 2000 a)]) (shutdown-agent! a) r)) + #t) + +(test "await-for returns #f when action takes too long" + (let ([a (agent 0)]) + (send a (lambda (v) (sleep (make-time 'time-duration 0 1)) (+ v 1))) + (let ([r (await-for 50 a)]) (shutdown-agent! a) r)) + #f) + +(test "await-for 0 still checks once" + (let ([a (agent 0)]) + ;; No queued action; marker drains immediately. + (send a + 1) + (await a) ;; drain real work + (let ([r (await-for 500 a)]) (shutdown-agent! a) r)) + #t) + +(test "await-for rejects negative ms" + (let ([a (agent 0)]) + (let ([r (guard (_ [else 'raised]) (await-for -1 a))]) + (shutdown-agent! a) r)) + 'raised) + +;;; ---- set-error-handler! ---------------------------------------- + +(test "error handler fires on action error" + (let* ([observed (make-parameter #f)] + [a (agent 0)]) + (set-error-handler! a (lambda (ag exn) (observed 'saw))) + (send a (lambda (v) (error 'boom "x"))) + (brief-sleep) + (let ([r (observed)]) (shutdown-agent! a) r)) + 'saw) + +(test "error handler sees the agent and the exception" + (let* ([seen-agent (make-parameter #f)] + [seen-exn (make-parameter #f)] + [a (agent 0)]) + (set-error-handler! a + (lambda (ag exn) + (seen-agent (eq? ag a)) + (seen-exn (condition? exn)))) + (send a (lambda (v) (error 'boom "x"))) + (brief-sleep) + (let ([r (list (seen-agent) (seen-exn))]) + (shutdown-agent! a) r)) + '(#t #t)) + +(test "error handler of #f clears it" + (let ([a (agent 0)]) + (set-error-handler! a (lambda (ag exn) #f)) + (set-error-handler! a #f) + (let ([r (agent-error-handler a)]) (shutdown-agent! a) r)) + #f) + +(test "set-error-handler! rejects non-procedure" + (let ([a (agent 0)]) + (let ([r (guard (_ [else 'raised]) (set-error-handler! a 42))]) + (shutdown-agent! a) r)) + 'raised) + +;;; ---- set-error-mode! ------------------------------------------- + +(test "default error mode is 'fail" + (let ([a (agent 0)]) + (let ([m (agent-error-mode a)]) (shutdown-agent! a) m)) + 'fail) + +(test "continue mode drops errors and keeps processing" + (let ([a (agent 0)]) + (set-error-mode! a 'continue) + (send a + 1) ;; -> 1 + (send a (lambda (v) (error 'boom "x"))) ;; swallowed + (send a + 10) ;; -> 11 + (await a) + (let ([v (agent-value a)] + [e (agent-error a)]) + (shutdown-agent! a) + (list v e))) + '(11 #f)) + +(test "continue mode fires handler each error" + (let* ([count 0] + [a (agent 0)]) + (set-error-mode! a 'continue) + (set-error-handler! a (lambda (ag exn) (set! count (+ count 1)))) + (send a (lambda (v) (error 'boom "x"))) + (send a (lambda (v) (error 'boom "y"))) + (send a + 5) + (await a) + (let ([c count]) (shutdown-agent! a) c)) + 2) + +(test "set-error-mode! rejects unknown mode" + (let ([a (agent 0)]) + (let ([r (guard (_ [else 'raised]) (set-error-mode! a 'bogus))]) + (shutdown-agent! a) r)) + 'raised) + ;;; ---- Summary --------------------------------------------------- (printf "~%std/agent: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1)) --- a/tests/test-atom.ss +++ b/tests/test-atom.ss @@ -203,6 +203,100 @@ (not (atom? (volatile! 0))) #t) +;;; ---- Validators (Round 5 §31) ---- + +(import (only (std misc atom) set-validator! get-validator)) + +(test "get-validator default is #f" + (get-validator (atom 0)) + #f) + +(test "set-validator! then get-validator round-trips" + (let ([a (atom 0)] + [v (lambda (n) (and (integer? n) (>= n 0)))]) + (set-validator! a v) + (eq? (get-validator a) v)) + #t) + +(test "set-validator! rejects installing on value that fails predicate" + (let ([a (atom -1)]) + (guard (exn [else 'caught]) + (set-validator! a (lambda (n) (>= n 0))) + 'passed)) + 'caught) + +(test "reset! honors validator (accept)" + (let ([a (atom 0)]) + (set-validator! a (lambda (n) (integer? n))) + (reset! a 42)) + 42) + +(test "reset! honors validator (reject)" + (let ([a (atom 0)]) + (set-validator! a (lambda (n) (integer? n))) + (guard (exn [else 'caught]) + (reset! a "not-an-int") + 'passed)) + 'caught) + +(test "reset! rejection leaves old value" + (let ([a (atom 7)]) + (set-validator! a (lambda (n) (integer? n))) + (guard (exn [else (deref a)]) + (reset! a "bad") + 'impossible)) + 7) + +(test "swap! honors validator" + (let ([a (atom 5)]) + (set-validator! a (lambda (n) (and (integer? n) (< n 10)))) + (swap! a + 3)) + 8) + +(test "swap! rejects and keeps old value" + (let ([a (atom 5)]) + (set-validator! a (lambda (n) (< n 10))) + (guard (exn [else (deref a)]) + (swap! a + 100))) + 5) + +(test "compare-and-set! honors validator (reject)" + (let ([a (atom 1)]) + (set-validator! a (lambda (n) (odd? n))) + (guard (exn [else (deref a)]) + (compare-and-set! a 1 2) + 'impossible)) + 1) + +(test "clearing validator by setting to #f" + (let ([a (atom 0)]) + (set-validator! a (lambda (n) (>= n 0))) + (set-validator! a #f) + (reset! a -42)) + -42) + +(test "validator that throws treated as rejection" + ;; Validator throws on the *new* value only; the current value + ;; passes so set-validator! installs cleanly. The throw then + ;; surfaces on reset!, which must leave the old value in place. + (let ([a (atom 1)]) + (set-validator! a (lambda (n) (if (= n 1) #t (error 'v "nope")))) + (guard (exn [else (deref a)]) + (reset! a 2) + 'impossible)) + 1) + +(test "validator not called on failing CAS" + ;; Install the validator first, then zero the counter, then test + ;; that CAS with a wrong `expected` skips the validator entirely. + (let ([a (atom 1)] + [calls 0]) + (set-validator! a (lambda (n) (set! calls (+ calls 1)) #t)) + (set! calls 0) + (compare-and-set! a 99 100) ;; current is 1, expected 99 — CAS fails + calls) + 0) + ;;; ---- Summary ---- (printf "~%atom: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1)) --- a/tests/test-multi.ss +++ b/tests/test-multi.ss @@ -182,6 +182,146 @@ (get-method car 'x)) 'raised)