;; lib/scheme/tests/control.sx — call/cc, dynamic-wind, exceptions.

(define scm-ctl-pass 0)
(define scm-ctl-fail 0)
(define scm-ctl-fails (list))

(define
  scm-ctl-test
  (fn
    (name actual expected)
    (if
      (= actual expected)
      (set! scm-ctl-pass (+ scm-ctl-pass 1))
      (begin
        (set! scm-ctl-fail (+ scm-ctl-fail 1))
        (append! scm-ctl-fails {:name name :actual actual :expected expected})))))

(define
  scm-ctl
  (fn (src) (scheme-eval (scheme-parse src) (scheme-standard-env))))

(define
  scm-ctl-all
  (fn
    (src)
    (scheme-eval-program (scheme-parse-all src) (scheme-standard-env))))

;; ── call/cc — escape continuations ──────────────────────────────
;; Single-shot only: when k is invoked, control jumps out of the
;; surrounding call/cc and the result of the entire call/cc form is
;; whatever was passed to k.

(scm-ctl-test
  "call/cc: no escape"
  (scm-ctl "(call/cc (lambda (k) 42))")
  42)
(scm-ctl-test
  "call/cc: simple escape"
  (scm-ctl "(call/cc (lambda (k) (+ 1 (k 42))))")
  42)
(scm-ctl-test
  "call/cc: escape past *"
  (scm-ctl "(+ 10 (call/cc (lambda (k) (* 2 (k 5)))))")
  15)
(scm-ctl-test
  "call/cc: alias call-with-current-continuation"
  (scm-ctl "(call-with-current-continuation (lambda (k) (k 99)))")
  99)
(scm-ctl-test
  "call/cc: doesn't escape if k unused"
  (scm-ctl "(+ 1 (call/cc (lambda (k) (* 100 1))))")
  101)

;; ── call/cc as early-exit for list search ───────────────────────
(scm-ctl-test
  "call/cc: detect-via-escape"
  (scm-ctl-all
    "(define (detect pred xs)\n       (call/cc\n         (lambda (return)\n           (for-each\n             (lambda (x) (if (pred x) (return x) #f))\n             xs)\n           #f)))\n     (detect (lambda (x) (> x 10)) '(1 5 7 12 20))")
  12)
(scm-ctl-test
  "call/cc: detect returns #f when no match"
  (scm-ctl-all
    "(define (detect pred xs)\n       (call/cc\n         (lambda (return)\n           (for-each\n             (lambda (x) (if (pred x) (return x) #f))\n             xs)\n           #f)))\n     (detect (lambda (x) (> x 100)) '(1 5 7))")
  false)

;; ── call/cc producing the captured k value ──────────────────────
(scm-ctl-test
  "call/cc: k is a procedure"
  (scm-ctl "(procedure? (call/cc (lambda (k) k)))")
  true)

;; ── Exceptions: raise / guard / with-exception-handler / error ──
(scm-ctl-test "raise + guard caught"
  (scm-ctl "(guard (e (else 'caught)) (raise 'boom))") "caught")
(scm-ctl-test "guard: number? matches"
  (scm-ctl "(guard (e ((number? e) e) (else 'other)) (raise 42))") 42)
(scm-ctl-test "guard: number? mismatches → else"
  (scm-ctl "(guard (e ((number? e) e) (else 'other)) (raise 'sym))")
  "other")
(scm-ctl-test "guard: no error → body value"
  (scm-ctl "(guard (e (else 'never)) 42)") 42)
(scm-ctl-test "guard: first matching clause wins"
  (scm-ctl
    "(guard (e ((number? e) 'num) ((symbol? e) 'sym) (else 'other)) (raise 'foo))")
  "sym")
(scm-ctl-test "guard: re-raises when no clause matches"
  (scm-ctl
    "(guard (e (else 'outer)) (guard (e ((number? e) 'inner)) (raise 'not-a-number)))")
  "outer")
(scm-ctl-test "guard: var bound in clause body"
  (scm-ctl "(guard (e ((symbol? e) e)) (raise 'the-symbol))")
  "the-symbol")
(scm-ctl-test "with-exception-handler: caught"
  (scm-ctl
    "(with-exception-handler (lambda (e) 'caught) (lambda () (raise 'oops)))")
  "caught")
(scm-ctl-test "with-exception-handler: no raise"
  (scm-ctl
    "(with-exception-handler (lambda (e) 99) (lambda () 42))")
  42)
(scm-ctl-test "with-exception-handler: handler sees the value"
  (scm-ctl
    "(with-exception-handler (lambda (e) (+ e 1)) (lambda () (raise 41)))")
  42)
(scm-ctl-test "error: irritants accessible"
  (scm-ctl
    "(guard (e ((error-object? e) (error-object-irritants e))) (error \"msg\" 1 2 3))")
  (list 1 2 3))
(scm-ctl-test "error: message accessible"
  (scheme-string-value
    (scm-ctl
      "(guard (e ((error-object? e) (error-object-message e))) (error \"the-msg\"))"))
  "the-msg")

;; ── dynamic-wind ────────────────────────────────────────────────
;; Basic version: runs before/thunk/after on success; before/after
;; on raise (with the raise still propagating after the after-thunk).
;; call/cc escape-out interaction is NOT yet tracked — deferred.

(scm-ctl-test "dynamic-wind: ordering on success"
  (scm-ctl-all
    "(define log '())
     (define (note x) (set! log (cons x log)))
     (dynamic-wind
       (lambda () (note 'before))
       (lambda () (note 'thunk) 42)
       (lambda () (note 'after)))
     (reverse log)")
  (list "before" "thunk" "after"))
(scm-ctl-test "dynamic-wind: returns thunk value"
  (scm-ctl
    "(dynamic-wind (lambda () 'b) (lambda () 42) (lambda () 'a))") 42)
(scm-ctl-test "dynamic-wind: after runs on raise"
  (scm-ctl-all
    "(define log '())
     (define (note x) (set! log (cons x log)))
     (guard (e (else 'caught))
       (dynamic-wind
         (lambda () (note 'before))
         (lambda () (raise 'boom))
         (lambda () (note 'after))))
     (reverse log)")
  (list "before" "after"))
(scm-ctl-test "dynamic-wind: raise propagates after after-thunk"
  (scm-ctl-all
    "(guard (e (else e))
       (dynamic-wind
         (lambda () 'b)
         (lambda () (raise 'the-raised))
         (lambda () 'a)))")
  "the-raised")
(scm-ctl-test "dynamic-wind: nested"
  (scm-ctl-all
    "(define log '())
     (define (note x) (set! log (cons x log)))
     (dynamic-wind
       (lambda () (note 'outer-before))
       (lambda ()
         (dynamic-wind
           (lambda () (note 'inner-before))
           (lambda () (note 'inner-thunk))
           (lambda () (note 'inner-after))))
       (lambda () (note 'outer-after)))
     (reverse log)")
  (list "outer-before" "inner-before" "inner-thunk"
        "inner-after" "outer-after"))

(define scm-ctl-tests-run! (fn () {:total (+ scm-ctl-pass scm-ctl-fail) :passed scm-ctl-pass :failed scm-ctl-fail :fails scm-ctl-fails}))