rose-ash/lib/common-lisp/tests/programs/parse-recover.sx

;; parse-recover.sx — Parser with skipped-token restart
;;
;; Classic CL pattern: a simple token parser that signals a condition
;; when it encounters an unexpected token. The :skip-token restart
;; allows the parser to continue past the offending token.
;;
;; Depends on: lib/common-lisp/runtime.sx already loaded.

;; ── condition type ─────────────────────────────────────────────────────────

(cl-define-condition "parse-error" (list "error") (list "token" "position"))

;; ── simple token parser ────────────────────────────────────────────────────
;;
;; parse-numbers: given a list of tokens (strings), parse integers.
;; Non-integer tokens signal parse-error with two restarts:
;;   skip-token   — skip the bad token and continue
;;   use-zero     — use 0 in place of the bad token

(define
  parse-numbers
  (fn
    (tokens)
    (define result (list))
    (define
      process
      (fn
        (toks)
        (if
          (empty? toks)
          result
          (let
            ((tok (first toks)) (rest-toks (rest toks)))
            (let
              ((n (string->number tok 10)))
              (if
                n
                (begin
                  (set! result (append result (list n)))
                  (process rest-toks))
                (cl-restart-case
                  (fn
                    ()
                    (cl-signal
                      (cl-make-condition
                        "parse-error"
                        "token"
                        tok
                        "position"
                        (len result)))
                    (set! result (append result (list 0)))
                    (process rest-toks))
                  (list "skip-token" (list) (fn () (process rest-toks)))
                  (list
                    "use-zero"
                    (list)
                    (fn
                      ()
                      (begin
                        (set! result (append result (list 0)))
                        (process rest-toks)))))))))))
    (process tokens)
    result))

;; ── tests ─────────────────────────────────────────────────────────────────

(define passed 0)
(define failed 0)
(define failures (list))

(define
  check
  (fn
    (label got expected)
    (if
      (= got expected)
      (set! passed (+ passed 1))
      (begin
        (set! failed (+ failed 1))
        (set!
          failures
          (append
            failures
            (list
              (str
                "FAIL ["
                label
                "]: got="
                (inspect got)
                " expected="
                (inspect expected)))))))))

(define
  reset-stacks!
  (fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list))))

;; All valid tokens
(reset-stacks!)
(check
  "all valid: 1 2 3"
  (cl-handler-bind
    (list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token"))))
    (fn () (parse-numbers (list "1" "2" "3"))))
  (list 1 2 3))

;; Skip bad token
(reset-stacks!)
(check
  "skip bad token: 1 x 3 -> (1 3)"
  (cl-handler-bind
    (list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token"))))
    (fn () (parse-numbers (list "1" "x" "3"))))
  (list 1 3))

;; Use zero for bad token
(reset-stacks!)
(check
  "use-zero for bad: 1 x 3 -> (1 0 3)"
  (cl-handler-bind
    (list (list "parse-error" (fn (c) (cl-invoke-restart "use-zero"))))
    (fn () (parse-numbers (list "1" "x" "3"))))
  (list 1 0 3))

;; Multiple bad tokens, all skipped
(reset-stacks!)
(check
  "skip multiple bad: a 2 b 4 -> (2 4)"
  (cl-handler-bind
    (list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token"))))
    (fn () (parse-numbers (list "a" "2" "b" "4"))))
  (list 2 4))

;; handler-case: abort on first bad token
(reset-stacks!)
(check
  "handler-case: abort on first bad"
  (cl-handler-case
    (fn () (parse-numbers (list "1" "bad" "3")))
    (list
      "parse-error"
      (fn
        (c)
        (str
          "parse error at position "
          (cl-condition-slot c "position")
          ": "
          (cl-condition-slot c "token")))))
  "parse error at position 1: bad")

;; Verify condition type hierarchy
(reset-stacks!)
(check
  "parse-error isa error"
  (cl-condition-of-type?
    (cl-make-condition "parse-error" "token" "x" "position" 0)
    "error")
  true)

;; ── summary ────────────────────────────────────────────────────────────────

(define parse-passed passed)
(define parse-failed failed)
(define parse-failures failures)